gnu: gnu-make-mesboot0: Downgrade to 3.80.

* gnu/packages/commencement.scm (gnu-make-mesboot0): Downgrade to 3.80.

Change-Id: I00b1f6ac934b573bf7845d78e8d4ac78dcd1d0f6

.dir-locals.el

@@ -98,9 +98,27 @@
   ((indent-tabs-mode . nil)
 
    ;; Emacs 28 changed the behavior of 'lisp-fill-paragraph', which causes the
-   ;; first line of package descriptions to extrude past 'fill-column'. The
-   ;; following variable reverts its behavior to the previous one.
-   (lisp-fill-paragraphs-as-doc-string nil)
+   ;; first line of package descriptions to extrude past 'fill-column', and
+   ;; somehow that is deemed more correct upstream (see:
+   ;; https://issues.guix.gnu.org/56197).
+   (eval . (progn
+             (require 'lisp-mode)
+             (defun emacs27-lisp-fill-paragraph (&optional justify)
+               (interactive "P")
+               (or (fill-comment-paragraph justify)
+                   (let ((paragraph-start
+                          (concat paragraph-start
+                                  "\\|\\s-*\\([(;\"]\\|\\s-:\\|`(\\|#'(\\)"))
+                         (paragraph-separate
+                          (concat paragraph-separate "\\|\\s-*\".*[,\\.]$"))
+                         (fill-column (if (and (integerp emacs-lisp-docstring-fill-column)
+                                               (derived-mode-p 'emacs-lisp-mode))
+                                          emacs-lisp-docstring-fill-column
+                                        fill-column)))
+                     (fill-paragraph justify))
+                   ;; Never return nil.
+                   t))
+             (setq-local fill-paragraph-function #'emacs27-lisp-fill-paragraph)))
 
    ;; This notably allows '(' in Paredit to not insert a space when the
    ;; preceding symbol is one of these.

Makefile.am

@@ -116,6 +116,7 @@ MODULES =					\
   guix/narinfo.scm				\
   guix/derivations.scm				\
   guix/grafts.scm				\
+  guix/remote-procedures.scm			\
   guix/repl.scm					\
   guix/rpm.scm					\
   guix/transformations.scm			\

configure.ac

@@ -2,7 +2,7 @@
 # Process this file with autoconf to produce a configure script.
 #
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012-2021, 2022-2023 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012-2021, 2022-2023, 2025 Ludovic Courtès <ludo@gnu.org>
 # Copyright © 2013, 2016 Mark H Weaver <mhw@netris.org>
 # Copyright © 2014-2016 Alex Kost <alezost@gmail.com>
 # Copyright © 2014-2016 David Thompson <davet@gnu.org>
@@ -130,7 +130,8 @@ if test "x$GUILD" = "x"; then
 fi
 
 dnl (guix ui), notably, requires 'default-optimization-level' added in 3.0.3.
-PKG_CHECK_MODULES([GUILE], [guile-3.0 >= 3.0.3])
+dnl (guix serialization) requires 'bytevector-slice' added in 3.0.9.
+PKG_CHECK_MODULES([GUILE], [guile-3.0 >= 3.0.9])
 
 dnl Get CFLAGS and LDFLAGS for libguile.
 GUILE_FLAGS

doc/contributing.texi

@@ -66,7 +66,7 @@ GNU Guix depends on the following packages:
 
 @itemize
 @item @url{https://gnu.org/software/guile/, GNU Guile}, version 3.0.x,
-version 3.0.3 or later;
+version 3.0.9 or later;
 @item @url{https://notabug.org/cwebber/guile-gcrypt, Guile-Gcrypt}, version
 0.1.0 or later;
 @item

doc/guix-cookbook.texi

@@ -22,7 +22,7 @@ Copyright @copyright{} 2020 André Batista@*
 Copyright @copyright{} 2020 Christine Lemmer-Webber@*
 Copyright @copyright{} 2021 Joshua Branson@*
 Copyright @copyright{} 2022, 2023 Maxim Cournoyer@*
-Copyright @copyright{} 2023-2025 Ludovic Courtès@*
+Copyright @copyright{} 2023--2026 Ludovic Courtès@*
 Copyright @copyright{} 2023 Thomas Ieong@*
 Copyright @copyright{} 2024 Florian Pelz@*
 Copyright @copyright{} 2025 45mg@*
@@ -5958,6 +5958,15 @@ installation instructions (@pxref{Binary Installation,,, guix, GNU Guix
 Reference Manual}).  Thanks to the installation script, this should be
 quick.  Once installation is complete, we need to make some adjustments.
 
+@quotation Note
+Starting from Guix version 1.5.0, @command{guix-daemon} runs without
+root privileges by default; previously installed systems can also be
+migrated to this ``rootless'' mode (@pxref{Build Environment Setup,,,
+guix, GNU Guix Reference Manual}).  Learn more about this change in a
+@uref{https://hpc.guix.info/blog/2025/03/build-daemon-drops-its-privileges/,
+2025 blog post}.
+@end quotation
+
 Since we want @code{guix-daemon} to be reachable not just from the head
 node but also from the compute nodes, we need to arrange so that it
 listens for connections over TCP/IP.  To do that, we'll edit the systemd
@@ -5972,13 +5981,12 @@ something like this:
 @ifnothtml
 @example
 ExecStart=/var/guix/profiles/per-user/root/current-guix/bin/guix-daemon \
-    --build-users-group=guixbuild \
     --listen=/var/guix/daemon-socket/socket --listen=0.0.0.0
 @end example
 @end ifnothtml
 @ifhtml
 @example
-ExecStart=/var/guix/profiles/per-user/root/current-guix/bin/guix-daemon --build-users-group=guixbuild --listen=/var/guix/daemon-socket/socket --listen=0.0.0.0
+ExecStart=/var/guix/profiles/per-user/root/current-guix/bin/guix-daemon --listen=/var/guix/daemon-socket/socket --listen=0.0.0.0
 @end example
 @end ifhtml
 
@@ -6014,32 +6022,51 @@ The @file{/gnu/store} directory can be exported read-only since only
 package}; thus, to allow users to install packages with @code{guix
 package}, this must be read-write.
 
-Users can create as many profiles as they like in addition to the
-default profile, @file{~/.guix-profile}.  For instance, @code{guix
-package -p ~/dev/python-dev -i python} installs Python in a profile
-reachable from the @code{~/dev/python-dev} symlink.  To make sure that
+@quotation Note
+Although it is rarely used, Guix allows for the creation of profiles in
+non-default locations.  For instance, @code{guix package -p
+~/dev/python-dev -i python} installs Python in a profile reachable from
+the @code{~/dev/python-dev} symlink instead of the default
+@file{~/.guix-profile}.
+
+To make sure that
 this profile is protected from garbage collection---i.e., that Python
 will not be removed from @file{/gnu/store} while this profile exists---,
 @emph{home directories should be mounted on the head node} as well so
 that @code{guix-daemon} knows about these non-standard profiles and
 avoids collecting software they refer to.
 
+@c The following paragraph refers to Guix commit
+@c d12c4452a49b355369636de1dfc766b5bad6437b, which changed
+@c 'time-machine' and 'shell' to store GC roots under /var/guix.
+Doing so is optional though: profiles created by default by
+@command{guix package}, @command{guix pull}, and @command{guix shell}
+are all stored under @file{/var/guix} and thus protected from garbage
+collection.
+@end quotation
+
 It may be a good idea to periodically remove unused bits from
 @file{/gnu/store} by running @command{guix gc} (@pxref{Invoking guix
 gc,,, guix, GNU Guix Reference Manual}).  This can be done by adding a
-crontab entry on the head node:
+systemd timer based on the one shipped with Guix:
 
 @example
-root@@master# crontab -e
+cp \
+ /var/guix/profiles/per-user/root/current-guix/lib/systemd/system/guix-gc.* \
+ /etc/systemd/system
 @end example
 
-@noindent
-... with something like this:
+Make sure to edit @file{guix-gc.service} and @file{guix-gc.timer} under
+@file{/etc/systemd/system} to adjust the parameters to your need: timer
+frequency, amount of free space, and whether to delete user's old
+generations.  We recommend executing @command{guix gc -F50G} every
+night, which will ensure that at least 50@tie{}GiB are available,
+without deleting user generations.  Once you're satisfied, you can start
+the timer:
 
 @example
-# Every day at 5AM, run the garbage collector to make sure
-# at least 10 GB are free on /gnu/store.
-0 5 * * 1  /usr/local/bin/guix gc -F10G
+systemctl daemon-reload
+systemctl start guix-gc.timer
 @end example
 
 We're done with the head node! Let's look at compute nodes now.

doc/guix.texi

@@ -7901,6 +7901,7 @@ package looks like this:
 
 @lisp
 (define-module (gnu packages hello)
+  #:use-module (guix gexp)
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix build-system gnu)
@@ -15124,8 +15125,8 @@ When @option{--lockfile} is specified, the importer will ignore other options
 and won't output package expressions, instead importing source expressions
 from @var{file}, a @file{Cargo.lock} file.
 
-@xref{Packaging Rust Crates,,, guix-cookbook, GNU Guix Cookbook}, for packaging
-workflow utilizing it.
+@xref{Packaging Rust Crates,,, guix-cookbook, GNU Guix Cookbook}, for
+a packaging workflow utilizing it.
 @end table
 
 @item elm
@@ -24320,6 +24321,58 @@ Whether to enable password-based authentication.
 @end table
 @end deftp
 
+@cindex EndleSSH
+@defvar endlessh-service-type
+This is the type for the
+@uref{https://github.com/skeeto/endlessh,EndleSSH} program that runs an
+SSH tar pit. By very slowly sending an SSH banner, this program keeps
+unwanted visitors locked away from the actual SSH daemon.
+
+For example, to specify a service running Endlessh on port @code{2222}, add
+this call to the operating system's @code{services} field:
+
+@lisp
+(service endlessh-service-type
+         (endlessh-configuration
+          (port-number 2222)))
+@end lisp
+@end defvar
+
+@deftp {Data Type} endlessh-configuration
+This data type represents the configuration of an EndleSSH service.
+
+@table @asis
+@item @code{endlessh} (default: @var{endlessh})
+The EndleSSH package to use.
+
+@item @code{port-number} (default: @code{22})
+The TCP port where the daemon waits for incoming connections.
+
+@item @code{log-level} (default: @code{1})
+The log level. @code{0} is quiet, @code{2} is very noisy.
+
+@item @code{syslog-output?} (default: @code{#t})
+Whether to enable syslog output.
+
+@item @code{pid-file} (default: @code{"/var/run/endlessh.pid"})
+File name of the daemon's PID file.
+
+@item @code{message-delay} (default: @code{10000})
+The endless banner is sent one line at a time. This is the delay in
+milliseconds between individual lines.
+
+@item @code{max-banner-length} (default: @code{32})
+The length of each line is randomized. This controls the maximum length
+of each line. Shorter lines may keep clients on for longer if they give
+up after a certain number of bytes.
+
+@item @code{max-clients} (default: @code{4096})
+Maximum number of connections to accept at a time. Connections beyond
+this are not immediately rejected, but will wait in the queue.
+
+@end table
+@end deftp
+
 @cindex AutoSSH
 @defvar autossh-service-type
 This is the type for the @uref{https://www.harding.motd.ca/autossh,

gnu/local.mk

@@ -1355,6 +1355,8 @@ dist_patch_DATA =						\
   %D%/packages/patches/gcc-asan-missing-include.patch		\
   %D%/packages/patches/gcc-boot-2.95.3.patch			\
   %D%/packages/patches/gcc-boot-4.6.4.patch			\
+  %D%/packages/patches/gcc-boot-4.6.4-riscv64-support.patch	\
+  %D%/packages/patches/gcc-boot-4.6.4-riscv64-libstdc++-support.patch	\
   %D%/packages/patches/gcc-cross-environment-variables.patch	\
   %D%/packages/patches/gcc-cross-gxx-include-dir.patch          \
   %D%/packages/patches/gcc-fix-texi2pod.patch			\
@@ -1901,6 +1903,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/minisat-install.patch			\
   %D%/packages/patches/miniz-for-pytorch.patch			\
   %D%/packages/patches/mit-krb5-hurd.patch			\
+  %D%/packages/patches/mitm-cache-head-requests.patch   	\
   %D%/packages/patches/mpc123-initialize-ao.patch		\
   %D%/packages/patches/mpg321-CVE-2019-14247.patch		\
   %D%/packages/patches/mpg321-gcc-10.patch			\

gnu/packages/bioinformatics.scm

@@ -138,6 +138,7 @@
   #:use-module (gnu packages node)
   #:use-module (gnu packages nss)
   #:use-module (gnu packages ocaml)
+  #:use-module (gnu packages oneapi)
   #:use-module (gnu packages pcre)
   #:use-module (gnu packages package-management)
   #:use-module (gnu packages parallel)
@@ -5674,7 +5675,7 @@ errors at the end of reads.")
 (define-public bowtie
   (package
     (name "bowtie")
-    (version "2.3.4.3")
+    (version "2.5.4")
     (source (origin
               (method git-fetch)
               (uri (git-reference
@@ -5683,40 +5684,51 @@ errors at the end of reads.")
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "1zl3cf327y2p7p03cavymbh7b00djc7lncfaqih33n96iy9q8ibp"))
-              (modules '((guix build utils)))
+                "020dwg059zmgqcfnxgg67qmn8rf207mwrybly39ncch1riva58z5"))
               (snippet
-               '(begin
-                  (substitute* "Makefile"
-                    ;; replace BUILD_HOST and BUILD_TIME for deterministic build
-                    (("-DBUILD_HOST=.*") "-DBUILD_HOST=\"\\\"guix\\\"\"")
-                    (("-DBUILD_TIME=.*") "-DBUILD_TIME=\"\\\"0\\\"\""))))))
+               #~(begin
+                   (use-modules (guix build utils))
+                   (substitute* "Makefile"
+                     ;; replace BUILD_HOST and BUILD_TIME for deterministic build
+                     (("-DBUILD_HOST=.*") "-DBUILD_HOST=\"\\\"guix\\\"\"")
+                     (("-DBUILD_TIME=.*") "-DBUILD_TIME=\"\\\"0\\\"\""))))))
     (build-system gnu-build-system)
     (arguments
-     `(#:make-flags
-       ,#~(list "allall"
-                "WITH_TBB=1"
-                (string-append "prefix=" #$output))
-       #:phases
-       (modify-phases %standard-phases
-         (replace 'configure
-           (lambda _
-             ;; This "extended character" is not considered valid.
-             (substitute* "processor_support.h"
-               (("“") "\"")
-               (("”") "\""))))
-         (replace 'check
-           (lambda _
-             (invoke "perl"
-                     "scripts/test/simple_tests.pl"
-                     "--bowtie2=./bowtie2"
-                     "--bowtie2-build=./bowtie2-build"))))))
+     (list
+      #:make-flags
+      #~(list "allall"
+              "WITH_TBB=1"
+              (string-append "prefix=" #$output)
+              (string-append "CC=" #$(cc-for-target)))
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-after 'unpack 'fix-prefix
+            (lambda _
+              (substitute* "Makefile"
+                (("/usr/local") #$output))))
+          (replace 'configure
+            (lambda _
+              ;; This "extended character" is not considered valid.
+              (substitute* "processor_support.h"
+                (("“") "\"")
+                (("”") "\""))))
+          (replace 'check
+            (lambda* (#:key tests? #:allow-other-keys)
+              (when tests?
+                (invoke "perl"
+                        "scripts/test/simple_tests.pl"
+                        "--bowtie2=./bowtie2"
+                        "--bowtie2-build=./bowtie2-build")))))))
     (inputs
-     `(("tbb" ,tbb-2020)
-       ("zlib" ,zlib)
-       ("python" ,python-wrapper)))
+     (list onetbb zlib))
     (native-inputs
-     (list perl perl-clone perl-test-deep perl-test-simple))
+     (list perl
+           perl-clone
+           perl-file-which
+           perl-test-deep
+           perl-test-simple
+           python-wrapper
+           which))
     (home-page "https://bowtie-bio.sourceforge.net/bowtie2/index.shtml")
     (synopsis "Fast and sensitive nucleotide sequence read aligner")
     (description

gnu/packages/crypto.scm

@@ -1814,7 +1814,7 @@ for creation and reading of DigiDoc files.")
 (define-public osslsigncode
   (package
     (name "osslsigncode")
-    (version "2.10")
+    (version "2.11")
     (source
      (origin
        (method git-fetch)
@@ -1823,7 +1823,7 @@ for creation and reading of DigiDoc files.")
              (commit version)))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "1fizcrcgavw5zkzws62pgz8ly5jnmrpv33whryabqgg9q5fwsf2j"))))
+        (base32 "17vzkrv4qzjrjinjlgk8fbimkzd5b5akkpangkpn8cdficxgibxr"))))
     (build-system cmake-build-system)
     (arguments
      (list

gnu/packages/dns.scm

@@ -852,7 +852,7 @@ Extensions} (DNSSEC).")
 (define-public knot
   (package
     (name "knot")
-    (version "3.5.2")
+    (version "3.5.3")
     (source
      (origin
        (method git-fetch)
@@ -861,7 +861,7 @@ Extensions} (DNSSEC).")
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0z1h22qjhjvjlli66nq3bl5nskdid6g86jk7v37y02vwy5xq93rm"))
+        (base32 "19nasxzkv805am7skkzs0vnqxjrdc4dqm67crdgqj36jli24zs3s"))
        (patches
         (search-patches "knot-remove-runtime-deps.patch"))
        (modules '((guix build utils)))

gnu/packages/electronics.scm

@@ -438,6 +438,51 @@ hardware designs in Verilog.")
       (home-page "https://github.com/ZipCPU/zipcpu/")
       (license license:lgpl3+))))
 
+(define-public gdstk
+  (package
+    (name "gdstk")
+    (version "0.9.62")
+    (source
+     (origin
+       (method git-fetch)
+       (uri (git-reference
+             (url "https://github.com/heitzmann/gdstk")
+             (commit (string-append "v" version))))
+       (sha256
+        (base32 "0q07g7h613yqszgs49vbnran3pz6yayc0hyisdnp4fi60cyzsz1l"))
+       (file-name (git-file-name name version))
+       (snippet '(begin
+                   ;; This snippet is also inherited by python-gdstk.
+                   (use-modules (guix build utils))
+                   ;; Disable 'external' source code directory.
+                   (substitute* "CMakeLists.txt"
+                     (("add_subdirectory\\(external\\)")
+                      ""))
+                   (delete-file-recursively "external")
+                   (substitute* "src/CMakeLists.txt"
+                     (("clipper)")
+                      "polyclipping)"))
+                   (substitute* "src/clipper_tools.cpp"
+                     (("clipper/")
+                      "polyclipping/"))))))
+    (build-system cmake-build-system)
+    (arguments
+     (list
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-before 'check 'build-examples
+            (lambda* (#:key tests? #:allow-other-keys)
+              (when tests?
+                (invoke "make" "examples")))))))
+    (inputs (list clipper qhull zlib))
+    (home-page "https://heitzmann.github.io/gdstk/")
+    (synopsis "Library for creation and manipulation of GDSII files")
+    (description
+     "@code{gdstk} is a library for creation and manipulation of GDSII
+layout files which are commonly used for
+@acronym{EDA, elecronic design automation} and chip design.")
+    (license license:boost1.0)))
+
 (define-public gerbv
   (package
     (name "gerbv")
@@ -2129,6 +2174,22 @@ programming language, as well as evaluation board definitions and a System on
 Chip toolkit.")
     (license license:bsd-3)))
 
+(define-public python-gdstk
+  (package
+    (inherit gdstk)
+    (name "python-gdstk")
+    (build-system pyproject-build-system)
+    (arguments (list #:test-flags #~(list ".")))
+    (native-inputs (list cmake-minimal python-pytest python-minimal-wrapper
+                         python-scikit-build-core))
+    (inputs (modify-inputs (package-inputs gdstk)
+              (prepend python-numpy)))
+    (synopsis "Python module for creation and manipulation of GDSII files")
+    (description
+     "@code{python-gdstk} is a Python library for creation
+and manipulation of GDSII layout files which are commonly used
+for @acronym{EDA, elecronic design automation} and chip design.")))
+
 (define-public python-klayout
   (package
     (name "python-klayout")

gnu/packages/emacs-xyz.scm

@@ -6627,7 +6627,7 @@ bibliographic references.")
 (define-public emacs-corfu
   (package
     (name "emacs-corfu")
-    (version "2.7")
+    (version "2.8")
     (source
      (origin
        (method git-fetch)
@@ -6636,7 +6636,7 @@ bibliographic references.")
               (commit version)))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "1x4jaf234x3scq7lq43pgnyn3qz3p441nc5whx4azb2v4chmrpym"))))
+        (base32 "0aliis64ifr17xyig99gbh0xczdkdlb4snq5pbrlnrjhzk1cksy4"))))
     (build-system emacs-build-system)
     (arguments
      (list
@@ -6715,7 +6715,7 @@ be regarded as @code{emacs-company-quickhelp} for @code{emacs-corfu}.")
 (define-public emacs-cape
   (package
     (name "emacs-cape")
-    (version "2.4")
+    (version "2.5")
     (source
      (origin
        (method git-fetch)
@@ -6724,7 +6724,7 @@ be regarded as @code{emacs-company-quickhelp} for @code{emacs-corfu}.")
              (commit version)))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0s2pirvws93nrrfcz1bwzbvmzgd5sv4hrf2012i5ag42c0skdqmh"))))
+        (base32 "12jk8jjk38mfldsgnimnsggxan5a5amzf2z17pwjq7dxhn87168j"))))
     (build-system emacs-build-system)
     (arguments
      (list
@@ -10899,18 +10899,27 @@ the speedbar window.")
 (define-public emacs-shell-maker
   (package
     (name "emacs-shell-maker")
-    (version "0.84.7")
+    (version "0.84.8")
     (source (origin
               (method git-fetch)
               (uri (git-reference
-                    (url "https://github.com/xenodium/shell-maker")
-                    (commit (string-append "v" version))))
+                     (url "https://github.com/xenodium/shell-maker")
+                     (commit (string-append "v" version))))
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "0x10qjhcym4nnv5zh4nwy7d46lp158q06w2iwgi265nl1bz9s7yq"))))
+                "1knswylikwipg8aqb7dip2jm1l8q3sxj8q0af31ipn92v6wh9bks"))))
     (build-system emacs-build-system)
-    (arguments (list #:tests? #f))      ;no tests
+    (arguments
+     (list #:tests? #f ; There are no tests.
+           #:phases
+           #~(modify-phases %standard-phases
+               (add-after 'unpack 'patch-curl
+                 (lambda* (#:key inputs #:allow-other-keys)
+                   (emacs-substitute-variables "shell-maker.el"
+                     ("shell-maker-curl-executable"
+                      (search-input-file inputs "/bin/curl"))))))))
+    (inputs (list curl))
     (home-page "https://github.com/xenodium/shell-maker")
     (synopsis "Create Emacs shells")
     (description "Shell Maker is a convenience wrapper around Comint mode.")
@@ -15480,7 +15489,7 @@ expansion and overwriting the marked region with a new snippet completion.")
 (define-public emacs-marginalia
   (package
     (name "emacs-marginalia")
-    (version "2.8")
+    (version "2.9")
     (source
      (origin
        (method git-fetch)
@@ -15489,7 +15498,7 @@ expansion and overwriting the marked region with a new snippet completion.")
              (commit version)))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "0fni7zs7az5ljpvd7ianbd26h9qwwsmmwwsc0b6l6ahy94sbza6p"))))
+        (base32 "0l77djsjamfnn8064gb2z9m3wxcyxcfnfyk5sjm8w82hqd73410f"))))
     (build-system emacs-build-system)
     (arguments
      (list
@@ -30169,8 +30178,8 @@ their meaning for the current Emacs major-mode.")
     (license license:gpl3+)))
 
 (define-public emacs-org-ref
-  (let ((commit "732a20bd236fd02db4a651da29f87f87f458a54a")
-        (revision "0"))
+  (let ((commit "dc2481d430906fe2552f9318f4405242e6d37396")
+        (revision "1"))
     (package
       (name "emacs-org-ref")
       (version (git-version "3.1" revision commit))
@@ -30183,22 +30192,15 @@ their meaning for the current Emacs major-mode.")
          (file-name (git-file-name name version))
          (sha256
           (base32
-           "1kbjxz56fvln6drd2wqdxrpgwjshzpdbyaq7dz0gn285z93y1knk"))))
+           "0q3fkqzdk52y6cnl5p6igrczr8v9l0jc1rp7pp27isjq8mjyvkgs"))))
       (build-system emacs-build-system)
       (arguments
        (list
+        #:emacs emacs-no-x              ;needs libxml support
         #:include #~(cons* "org-ref.org" "org-ref.bib" %default-include)
         #:exclude #~(list
                      ;; author doesn't recommend using it
-                     "org-ref-pdf.el")
-        #:phases
-        #~(modify-phases %standard-phases
-            (add-before 'check 'skip-failing-test
-              (lambda _
-                (substitute* "test/all-org-test.el"
-                  (("\\(ert-deftest preprocess .*" all)
-                   (string-append all
-                                  " (skip-unless (libxml-available-p))"))))))))
+                     "org-ref-pdf.el")))
       (propagated-inputs
        (list emacs-avy
              emacs-citeproc
@@ -30209,6 +30211,7 @@ their meaning for the current Emacs major-mode.")
              emacs-hydra
              emacs-ox-pandoc
              emacs-parsebib
+             emacs-pdf-tools
              emacs-request
              emacs-s))
       (native-inputs (list emacs-ert-runner))
@@ -36542,8 +36545,8 @@ the standard @code{Dockerfile} file format.")
 (define-public emacs-lsp-mode
   ;; Last release is one year old.
   ;; Latest revision enables support for new lsp spec 3.17 features.
-  (let ((commit "147233313576c844e2bf56640827b0d0e5c2ee6c")
-        (revision "0"))
+  (let ((commit "328c97945c345e32e4b8fd6bb5ccd6bb6c5d462f")
+        (revision "1"))
     (package
       (name "emacs-lsp-mode")
       (version (git-version "9.0.1" revision commit)) ;taken from lsp-mode.el
@@ -36555,11 +36558,11 @@ the standard @code{Dockerfile} file format.")
                 (commit commit)))
          (file-name (git-file-name name version))
          (sha256
-          (base32 "14317wgi0mrxbcrlgrfqyf80lh86n7x6bv07b43cxl3k4c4fqk0l"))))
+          (base32 "0dyk685q6z7z4bcb9pnwb045b819j6qkbm0qng4kn677laa51ikn"))))
       (build-system emacs-build-system)
       (arguments
        (list
-        #:emacs emacs                   ;need libxml support
+        #:emacs emacs-no-x              ;need libxml support
         #:test-command #~(list "ert-runner"
                                "-L" "."
                                "-L" "clients"

gnu/packages/file-systems.scm

@@ -1197,7 +1197,7 @@ files mistakenly overwritten or destroyed just a few seconds ago.")
 (define-public disorderfs
   (package
     (name "disorderfs")
-    (version "0.6.0")
+    (version "0.6.2")
     (source
      (origin
        (method git-fetch)
@@ -1207,12 +1207,12 @@ files mistakenly overwritten or destroyed just a few seconds ago.")
        (file-name (git-file-name name version))
        (sha256
         (base32
-         "14x57qnqifx6hal1yb2bnrda9l12z19vhqlq850qax23z362q53q"))))
+         "03bz03y7dx5hqv1c1vl7l1axzjr86cd2cddl1qkyqf8vsrn4ds6m"))))
     (build-system gnu-build-system)
     (native-inputs
      (list pkg-config))
     (inputs
-     (list fuse-2 attr))
+     (list fuse-3.18 attr))
     (arguments
      `(#:phases (modify-phases %standard-phases
                   (delete 'configure))  ; no configure script

gnu/packages/freedesktop.scm

@@ -42,6 +42,7 @@
 ;;; Copyright © 2024, 2025 dan <i@dan.games>
 ;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2025 wvlab <me@wvlab.xyz>
+;;; Copyright © 2025 jgart <jgart@dismail.de>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -328,6 +329,45 @@ some of the freedesktop.org specifications.")
 will pick hardware planes for these layers if possible.")
     (license license:expat)))
 
+(define-public lisgd
+  (package
+    (name "lisgd")
+    (version "0.4.0")
+    (source
+     (origin
+       (method git-fetch)
+       (uri (git-reference
+              (url "https://git.sr.ht/~mil/lisgd")
+              (commit version)))
+       (sha256
+        (base32
+         "0rkm6d3jn0i1fwf5qj47hv8w9aax5fijhccnc6f6v59q3aj5jd4n"))
+       (file-name (git-file-name name version))))
+    (build-system gnu-build-system)
+    (arguments
+     (list
+      #:tests? #f ; There are no tests.
+      #:make-flags
+      #~(list
+         (string-append "CC=" #$(cc-for-target))
+         (string-append "PREFIX=" %output)
+         (string-append "CPPFLAGS="
+                        "-DWITH_WAYLAND "
+                        "-I" #$libinput "/include "
+                        "-I" #$wayland "/include")
+         (string-append "LDFLAGS="
+                        "-L" #$libinput "/lib "
+                        "-L" #$wayland "/lib"))
+      #:phases
+      #~(modify-phases %standard-phases
+          (delete 'configure)))) ; There is no configure script.
+    (inputs (list libinput libx11 wayland))
+    (home-page "https://git.sr.ht/~mil/lisgd")
+    (synopsis "Bind gestures via libinput touch events")
+    (description "Bind gestures on touchscreens and unsupported gesture
+devices via libinput touch events.")
+    (license (list license:expat license:x11))))
+
 (define-public malcontent
   (package
     (name "malcontent")

gnu/packages/linux.scm

@@ -4878,7 +4878,7 @@ processes currently causing I/O.")
 (define-public iotop
   (package
     (name "iotop")
-    (version "1.30")
+    (version "1.31")
     (source
      (origin
        (method git-fetch)
@@ -4887,7 +4887,7 @@ processes currently causing I/O.")
              (commit (string-append "v" version))))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "1sijsk13bkrhsc5bc8f5i97a1ayhivak9pfinnyli57dh22w4k1g"))))
+        (base32 "19ccdiw3flzk7gki90rc1nifmma79g2l87vhls4d2xr4z763m4nc"))))
     (build-system gnu-build-system)
     (arguments
      (list #:make-flags
@@ -4985,6 +4985,21 @@ user-space processes.")
     (license (list license:lgpl2.1      ; library
                    license:gpl2+))))    ; command-line utilities
 
+(define-public fuse-3.18
+  (package
+    (inherit fuse)
+    (name "fuse")
+    (version "3.18.1")
+    (source (origin
+              (method url-fetch)
+              (uri
+               (string-append "https://github.com/libfuse/libfuse/releases/"
+                              "download/fuse-" version
+                              "/fuse-" version ".tar.gz"))
+              (sha256
+               (base32
+                "0b1jp5gp2gv40gv6cvmv86rcr4l0mdh050qbvnxl0xcwya45qffx"))))))
+
 (define-public fuse-2
   (package
     (inherit fuse)

gnu/packages/lua.scm

@@ -22,7 +22,7 @@
 ;;; Copyright © 2023 Valter Nazianzeno <manipuladordedados@gmail.com>
 ;;; Copyright © 2023 Timo Wilken <guix@twilken.net>
 ;;; Copyright © 2024 Jan Wielkiewicz <tona_kosmicznego_smiecia@interia.pl>
-;;; Copyright © 2024 Maxim Cournoyer <maxim@guixotic.coop>
+;;; Copyright © 2024, 2026 Maxim Cournoyer <maxim@guixotic.coop>
 ;;; Copyright © 2025 Zheng Junjie <z572@z572.online>
 ;;; Copyright © 2025 Ashish SHUKLA <ashish.is@lostca.se>
 ;;;
@@ -72,6 +72,7 @@
   #:use-module (gnu packages linux)
   #:use-module (gnu packages m4)
   #:use-module (gnu packages ncurses)
+  #:use-module (gnu packages ninja)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages pretty-print)
   #:use-module (gnu packages rdf)
@@ -395,6 +396,241 @@ directory structure and file attributes.")
 (define-public lua5.2-filesystem
   (make-lua-filesystem "lua5.2-filesystem" lua-5.2))
 
+(define-public lua-bee
+  ;; There are no releases; use the commit known to work with the packaged
+  ;; luamake.
+  (let ((commit "fe3feb2b62e8f0179dad5abb438ed4df39f675d4")
+        (revision "0"))
+    (package
+      (name "lua-bee")
+      (version (git-version "0.0.0" revision commit))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                       (url "https://github.com/actboy168/bee.lua/")
+                       (commit commit)
+                       ;; Requires a few git submodules such as the Lua
+                       ;; sources to patch and a few source libraries.
+                       (recursive? #t)))
+                (file-name (git-file-name name version))
+                (sha256
+                 (base32
+                  "1iv4cdkgcs123zw67ngq4jfbp7p7hkmj8zg2lbblipmm0hivhbd2"))))
+      (build-system gnu-build-system)
+      (arguments
+       (list
+        ;; TODO: Re-enable the tests after luamake can use a newer bee commit
+        ;; (see:
+        ;; <https://github.com/actboy168/bee.lua/commit/679c566f0f26bcf0c19e37066e678993122e1f34>).
+        #:tests? #f
+        #:phases
+        #~(modify-phases %standard-phases
+            (delete 'configure)
+            (replace 'build
+              (lambda* (#:key parallel-build? #:allow-other-keys)
+                (invoke "luamake"
+                        "-EXE" "lua"
+                        "-notest"
+                        "-j" (if parallel-build?
+                                 (number->string (parallel-job-count))
+                                 "1")
+                        "-v")))
+            (replace 'check
+              (lambda* (#:key parallel-tests? tests? #:allow-other-keys)
+                (when tests?
+                  (invoke "luamake"
+                          "-EXE" "lua"
+                          "-j" (if parallel-tests?
+                                   (number->string (parallel-job-count))
+                                   "1")
+                          "test" "-v"))))
+            (replace 'install
+              (lambda _
+                (install-file "build/bin/lua"
+                              (string-append #$output "/bin"))
+                (install-file "build/bin/bee.so"
+                              (string-append #$output "/lib/")))))))
+      (native-inputs (list luamake))
+      (home-page "https://github.com/actboy168/bee.lua/")
+      (synopsis "Lua runtime with a few extra features")
+      (description "The Bee Lua runtime implements a few extra features
+such as:
+@itemize
+@item Deterministic tables traversal
+@item Enable @code{lua_assert} in debug mode
+@item Add error hook (for debugger)
+@item Add resume/yield hook (for debugger)
+@item Disable tail calls in debug mode (for debugger)
+@end itemize")
+      (license license:expat))))
+
+(define-public luamake
+  (package
+    (name "luamake")
+    (version "1.7")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                     (url "https://github.com/actboy168/luamake")
+                     (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "075sp8dpcb81kwrpp843f1y00kvaqan09np6spf6b72z5dhf6aiw"))))
+    (build-system gnu-build-system)
+    (arguments
+     (list
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-after 'unpack 'copy-lua-bee-sources
+            (lambda* (#:key native-inputs inputs #:allow-other-keys)
+              (copy-recursively (dirname
+                                 (search-input-directory
+                                  (or native-inputs inputs) "bee"))
+                                "bee.lua")))
+          (add-after 'unpack 'patch-commands
+            (lambda* (#:key inputs #:allow-other-keys)
+              (substitute* "scripts/action.lua"
+                (("\"ninja\"")
+                 (format #f "~s" (search-input-file inputs "bin/ninja"))))))
+          (delete 'configure)
+          (replace 'build
+            (lambda* (#:key parallel-build? #:allow-other-keys)
+              (invoke "compile/build.sh" "-j"
+                      (if parallel-build?
+                          (number->string (parallel-job-count))
+                          "1")
+                      "notest" "-v")))
+          (replace 'check
+            (lambda* (#:key parallel-tests? tests? #:allow-other-keys)
+              (when tests?
+                (invoke "compile/build.sh" "-j"
+                        (if parallel-tests?
+                            (number->string (parallel-job-count))
+                            "1")
+                        "test" "-v"))))
+          (replace 'install
+            (lambda _
+              (let ((bin (string-append #$output "/bin"))
+                    (lib (string-append #$output "/lib/luamake")))
+                (install-file "luamake" lib)
+                (install-file "main.lua" lib)
+                (copy-recursively "scripts"
+                                  (string-append lib "/scripts"))
+                (copy-recursively "tools"
+                                  (string-append lib "/tools"))
+                (mkdir bin)
+                (symlink (string-append lib "/luamake")
+                         (string-append bin "/luamake"))))))))
+    (native-inputs (list (package-source lua-bee)
+                         ninja))
+    (inputs (list ninja))
+    (home-page "https://github.com/actboy168/luamake")
+    (synopsis "Make-inspired configuration and build system")
+    (description "Luamake is a platform independent configuration and
+build system that uses the standard Lua command-line interpreter.")
+    (license license:expat)))
+
+(define-public lua-language-server
+  (package
+    (name "lua-language-server")
+    (version "3.16.4")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                     (url "https://github.com/LuaLS/lua-language-server")
+                     (commit version)
+                     ;; There are quite a few bundled Lua libraries under the
+                     ;; '3rd' and 'meta/3rd' directories; most are currently
+                     ;; not packaged in Guix, and they all track exact
+                     ;; commits, so it would be annoying to maintain them as
+                     ;; separate origins (on top of having to patch the build
+                     ;; system to unbundle them).
+                     (recursive? #t)))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "0kbbwz9cjw9b8sii2hki51s968n551r8z46h9gp9bd2m3g3l1l75"))))
+    (build-system gnu-build-system)
+    (arguments
+     (list
+      ;; The test suite currently fails with luamake apparently attempting to
+      ;; find the bee.so shared object (see:
+      ;; <https://github.com/LuaLS/lua-language-server/issues/3325>).
+      #:tests? #f
+      #:phases
+      #~(modify-phases %standard-phases
+          (delete 'configure)
+          (replace 'build
+            (lambda* (#:key parallel-build? #:allow-other-keys)
+              (invoke "luamake"
+                      "-notest"
+                      "-j" (if parallel-build?
+                               (number->string (parallel-job-count))
+                               "1")
+                      "-v")))
+          (replace 'check
+            (lambda* (#:key parallel-tests? tests? #:allow-other-keys)
+              (when tests?
+                (invoke "luamake"
+                        "-j" (if parallel-tests?
+                                 (number->string (parallel-job-count))
+                                 "1")
+                        "test" "-v"))))
+          (replace 'install
+            ;; This is inspired by the package definition in Slackware.
+            (lambda* (#:key inputs #:allow-other-keys)
+              (let* ((bin (string-append #$output "/bin"))
+                     (lib (string-append #$output
+                                         "/libexec/lua-language-server"))
+                     (lib/bin (string-append lib "/bin")))
+                ;; XXX: The binary expects some odd layout to find its resources,
+                ;; hence the bin subdirectory under libexec.
+                (mkdir-p lib)
+                (for-each (lambda (x)
+                            (copy-recursively x (string-append lib "/" x)))
+                          (list "bin"
+                                "debugger.lua"
+                                "locale"
+                                "main.lua"
+                                "meta"
+                                "script"))
+                ;; Create a custom wrapper, adjusted to log elsewhere than in
+                ;; its read-only location under the store.
+                (mkdir bin)
+                (call-with-output-file (string-append bin "/lua-language-server")
+                  (lambda (p)
+                    (format p "#!~a
+exec ~a --logpath=\"/tmp/runtime-$USER/lua-language-server/log\" \
+--metapath=\"/tmp/runtime-$USER/lua-language-server/meta\" \"$@\""
+                            (search-input-file inputs "bin/sh")
+                            (string-append lib/bin
+                                           "/lua-language-server"))))
+                (chmod (string-append bin "/lua-language-server") #o755)))))))
+    (native-inputs (list luamake))
+    (inputs (list bash-minimal))        ;for the wrapper
+    (home-page "https://github.com/LuaLS/lua-language-server")
+    (synopsis "Lua language server")
+    (description "The Lua language server provides various language
+ features for Lua to make development easier and faster, including:
+@itemize
+@item Support for all recent versions of Lua, including LuaJIT
+@item Jump to definition
+@item Dynamic type checking
+@item Find references
+@item Diagnostics/Warnings
+@item Syntax checking
+@item Element renaming
+@item Hover to view details on variables, functions, and more
+@item Auto-completion
+@item Support for libraries
+@item Code formatting
+@item Spell checking
+@item Custom plugins
+@item Documentation generation
+@end itemize")
+    (license license:expat)))
+
 (define (make-lua-ossl name lua)
   (package
     (name name)

gnu/packages/machine-learning.scm

@@ -2594,15 +2594,15 @@ to return meaningful clusters (if there are any).")
 (define-public python-pynndescent
   (package
     (name "python-pynndescent")
-    (version "0.5.13")
+    (version "0.6.0")
     (source
      (origin
        (method url-fetch)
        (uri (pypi-uri "pynndescent" version))
        (sha256
-        (base32 "1yq0k15964klz7135gpa7rcpixywzs4zxmcp8p4fw7haxv058hnp"))))
+        (base32 "1x94mjdf62f2yqql50qn0qjh4bkhwdvx7xx9aph421s0bgxy1zbz"))))
     (build-system pyproject-build-system)
-    (native-inputs (list python-pytest python-setuptools python-wheel))
+    (native-inputs (list python-pytest python-setuptools))
     (propagated-inputs (list python-importlib-metadata
                              python-joblib
                              python-llvmlite
@@ -6332,13 +6332,13 @@ linear algebra routines needed for structured matrices (or operators).")
 (define-public python-gpytorch
   (package
     (name "python-gpytorch")
-    (version "1.14.2")
+    (version "1.15.1")
     (source (origin
               (method url-fetch)
               (uri (pypi-uri "gpytorch" version))
               (sha256
                (base32
-                "1c30348kjawg0cl522qvbljg6adyy5bcpmqdg4mh09zk8r8z0hla"))))
+                "1y8p1mpn00jjimszljmyczcg4bxcvd1n1czihnbykhy4qm74vn3n"))))
     (build-system pyproject-build-system)
     (arguments
      (list #:test-flags
@@ -6368,7 +6368,7 @@ linear algebra routines needed for structured matrices (or operators).")
 (define-public python-botorch
   (package
     (name "python-botorch")
-    (version "0.16.0")
+    (version "0.16.1")
     (source (origin
               (method git-fetch) ;no tests in PyPI
               (uri (git-reference
@@ -6377,7 +6377,7 @@ linear algebra routines needed for structured matrices (or operators).")
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "1bk7ks2g0qfrjsi4vqy72jkc6pr0pcqq4k5z6dmqqs0ajxc2d5sy"))))
+                "0md7y9nvnnjirky58qpcr127klqqlcc8srbppvqmbphsak1qvngj"))))
     (build-system pyproject-build-system)
     (arguments
      ;; 7 failed, 1502 passed, 1 skipped, 1 deselected, 807 warnings

gnu/packages/mail.scm

@@ -3094,16 +3094,14 @@ converts them to maildir format directories.")
 (define-public mblaze
   (package
     (name "mblaze")
-    (version "1.2")
+    (version "1.4")
     (source
      (origin
-       (method git-fetch)
-       (uri (git-reference
-             (url "https://github.com/leahneukirchen/mblaze")
-             (commit (string-append "v" version))))
-       (file-name (git-file-name name version))
+       (method url-fetch)
+       (uri (string-append "https://leahneukirchen.org/releases/"
+                           name "-" version ".tar.gz"))
        (sha256
-        (base32 "0fa8s9dp5ilwmfcwkx72x2b5i0maa5sl97hv2cdknqmc27gv0b1c"))))
+        (base32 "06x4k1zvhzzk9gwz84hp2c5ijrxf0w54lgwcsgin66g3z6rz5dkv"))))
     (outputs '("out" "contrib"))
     (build-system gnu-build-system)
     (inputs (list bash-minimal

gnu/packages/maths.scm

@@ -11277,7 +11277,7 @@ architecture.")
 (define-public python-mathics-scanner
   (package
     (name "python-mathics-scanner")
-    (version "1.4.1")
+    (version "2.0.0")
     (source
      (origin
        (method git-fetch)
@@ -11287,7 +11287,7 @@ architecture.")
        (file-name (git-file-name name version))
        (sha256
         (base32
-         "0y34kzqha5wp6n8cyvhhz47mq33x9kwi8ibj67q6pf08qslg154n"))))
+         "1illmj40rynrhqwr5sfh2mkj2wnpvaqrmvlh56h7za3d823pf5jz"))))
     (build-system pyproject-build-system)
     (arguments
      (list
@@ -11299,15 +11299,18 @@ architecture.")
               (substitute* "mathics_scanner/version.py"
                (("__version__=\"[^\"]*\"")
                 (string-append "__version__=\"" #$version "\"")))
+              ;; Generate JSON character/operator tables (character-tables.json,
+              ;; operators.json) which are pre-generated in the PyPI tarball
+              ;; but not in git.  The Makefile runs this script before
+              ;; 'make dist'.  Unlike in mathics-core, running the script here
+              ;; works because it writes to its own source tree being built;
+              ;; in mathics-core, the script tries to write to the installed
+              ;; python-mathics-scanner package which is not allowed.
               (invoke "bash" "./admin-tools/make-JSON-tables.sh")
               ;; Missing installation of "operators.yml".
               (substitute* "pyproject.toml"
                (("\"data/named-characters.yml\",")
-                "\"data/named-characters.yml\", \"data/operators.yml\","))
-              ;; Would cause a crash at runtime every time you select
-              ;; anything when running build_tables.py .
-              (substitute* "mathics_scanner/generate/build_tables.py"
-               (("\"operator-to-amslatex\",") "")))))))
+                "\"data/named-characters.yml\", \"data/operators.yml\",")))))))
     (propagated-inputs (list python-chardet python-click python-pyyaml))
     (native-inputs (list python-pytest python-setuptools python-wheel))
     (home-page "https://mathics.org/")
@@ -11343,7 +11346,7 @@ the Wolfram language.")
 (define-public python-mathics-core
   (package
     (name "python-mathics-core")
-    (version "8.0.1")
+    (version "9.0.0")
     (source (origin
               (method git-fetch)
               (uri (git-reference
@@ -11352,18 +11355,15 @@ the Wolfram language.")
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "1ikgw3w3silxisih92g1wgcwb37k7qkwfmdv5r6yy4ki74qvyk5q"))))
+                "19232vs3sxg1nq32cas8hwsiwvp6nzpnz4jzjjahpvrv1bl62prs"))))
     (arguments
      `(;; <https://github.com/pytest-dev/pytest/pull/10173> is missing .closed
-       #:tests? #f ;TODO: update package
        #:test-flags '("-s")
        #:phases
        (modify-phases %standard-phases
          (add-after 'unpack 'patch-bugs
            (lambda _
              (substitute* "pyproject.toml"
-              (("\"data/*.json\",")
-              "\"data/*.json\", \"data/operator-tables.json\",")
               (("\"autoload/\\*.m\",")
                ;; They forgot to install autoload/rules/*.m
                "\"autoload/*.m\", \"autoload/rules/*.m\","))
@@ -11371,9 +11371,33 @@ the Wolfram language.")
              (substitute* "mathics/builtin/files_io/files.py"
               (("https://raw.githubusercontent.com/Mathics3/mathics-core/master/README.rst")
                (string-append (getcwd) "/README.rst")))
-             ;; setup.py has some weird acrobatics that cannot work right.
-             (invoke "mathics3-generate-operator-json-table" "-o"
-                     "mathics/data/operator-tables.json")))
+             ;; llvmlite 0.45+ auto-initializes LLVM; calling initialize()
+             ;; now raises RuntimeError.
+             ;; <https://llvmlite.readthedocs.io/en/v0.45.0/user-guide/binding/initialization-finalization.html>
+             (substitute* "mathics/compile/compile.py"
+              (("llvm\\.initialize\\(\\)") "pass"))
+             ;; The JSON operator tables (op-tables.json, operator-tables.json)
+             ;; are pre-generated in the PyPI tarball but not in git.
+             ;; The Makefile runs admin-tools/make-JSON-tables.sh before
+             ;; 'make dist', but that script also writes to the scanner's
+             ;; default location which is read-only in the store.  Run the
+             ;; needed commands directly.  setup.py has fallback generation
+             ;; code but it's buggy: it writes operator-tables.json to the
+             ;; wrong path and op-tables.json is missing
+             ;; --field=operator-to-amslatex.  Creating the files first
+             ;; makes setup.py's 'if not os.path.exists' checks pass and
+             ;; the buggy code is skipped.
+             (with-directory-excursion "mathics/data"
+               (invoke "mathics3-generate-json-table"
+                       "--field=ascii-operator-to-symbol"
+                       "--field=ascii-operator-to-unicode"
+                       "--field=ascii-operator-to-wl-unicode"
+                       "--field=operator-to-ascii"
+                       "--field=operator-to-amslatex"
+                       "--field=operator-to-unicode"
+                       "-o" "op-tables.json")
+               (invoke "mathics3-generate-operator-json-table"
+                       "-o" "operator-tables.json"))))
          (add-before 'check 'prepare-check
            (lambda* (#:key inputs outputs #:allow-other-keys)
              ;(copy-file "operator-tables.json" "mathics/data/operator-tables.json")
@@ -11383,7 +11407,12 @@ the Wolfram language.")
            (lambda _
              ;; Otherwise 210 tests fail because the real output would use
              ;; unicode arrow characters.  With this, only 18 (symbolic) tests fail.
-             (setenv "MATHICS_CHARACTER_ENCODING" "ASCII"))))))
+             (setenv "MATHICS_CHARACTER_ENCODING" "ASCII")))
+         (add-before 'check 'set-home
+           (lambda _
+             ;; The sanity check imports mathics which tries to create a
+             ;; config directory in HOME.  Set HOME to a writable location.
+             (setenv "HOME" "/tmp"))))))
     (build-system pyproject-build-system)
     (native-inputs (list python-pytest python-setuptools python-wheel))
     (inputs (list llvm))
@@ -11409,13 +11438,13 @@ to Wolfram.")
 (define-public python-mathicsscript
   (package
     (name "python-mathicsscript")
-    (version "8.0.0")
+    (version "9.0.0")
     (source
      (origin
        (method url-fetch)
        (uri (pypi-uri "mathicsscript" version))
        (sha256
-        (base32 "12si397b9ap5ibvbap72bvkmssh8hdap8jbmdmhsj1qdb1axrac4"))))
+        (base32 "0pamvbmm8ichxapblfck913frdmr82vmb0s2jbiiy7iil5bzn59i"))))
     (build-system pyproject-build-system)
     (arguments
      `(#:phases
@@ -11443,13 +11472,13 @@ Mathics3.")
 (define-public python-mathics-django
   (package
     (name "python-mathics-django")
-    (version "8.0.1")
+    (version "9.0.0")
     (source
      (origin
        (method url-fetch)
-       (uri (pypi-uri "Mathics_Django" version))
+       (uri (pypi-uri "mathics_django" version))
        (sha256
-        (base32 "1cwvm72w6c3vz49gj09ihiwicj291ia51xhkxgi9z88a9vszx5pq"))))
+        (base32 "1lnqqi3ssr2xdss66asvd02b13igy75264yir0w1v6d1gznn93j5"))))
     (build-system pyproject-build-system)
     (arguments
      `(#:phases

gnu/packages/patches/gcc-boot-4.6.4-riscv64-libstdc++-support.patch

@@ -0,0 +1,31 @@
+This is part 2 of the diff between Ekaitz's branch and upstream's releases/gcc-4.6.4 branch.
+It only contains the libstdc++ diff.
+
+diff --git a/libstdc++-v3/config/os/generic/os_defines.h b/libstdc++-v3/config/os/generic/os_defines.h
+index 3199bf30bb3..b8d7c16361e 100644
+--- a/libstdc++-v3/config/os/generic/os_defines.h
++++ b/libstdc++-v3/config/os/generic/os_defines.h
+@@ -33,4 +33,9 @@
+ // System-specific #define, typedefs, corrections, etc, go here.  This
+ // file will come before all others.
+
++// Disable the weak reference logic in gthr.h for os/generic because it
++// is broken on every platform unless there is implementation specific
++// workaround in gthr-posix.h and at link-time for static linking.
++#define _GLIBCXX_GTHREAD_USE_WEAK 0
++
+ #endif
+diff --git a/libstdc++-v3/configure.host b/libstdc++-v3/configure.host
+index e29404c026f..5bbeb7f3763 100644
+--- a/libstdc++-v3/configure.host
++++ b/libstdc++-v3/configure.host
+@@ -236,6 +236,9 @@ case "${host_os}" in
+   freebsd*)
+     os_include_dir="os/bsd/freebsd"
+     ;;
++  linux-musl*)
++    os_include_dir="os/generic"
++    ;;
+   gnu* | linux* | kfreebsd*-gnu | knetbsd*-gnu)
+     if [ "$uclibc" = "yes" ]; then
+       os_include_dir="os/uclibc"

gnu/packages/patches/mitm-cache-head-requests.patch

@@ -0,0 +1,69 @@
+Upstream-status: <https://github.com/chayleaf/mitm-cache/pull/5>
+
+diff --git a/src/main.rs b/src/main.rs
+index d9f760f..215ed89 100644
+--- a/src/main.rs
++++ b/src/main.rs
+@@ -1,5 +1,6 @@
+ use base64::Engine;
+ use clap::{Parser, Subcommand};
++use futures_util::StreamExt;
+ use http_body_util::BodyExt;
+ use hudsucker::{
+     certificate_authority::RcgenAuthority,
+@@ -11,6 +12,7 @@ use hudsucker::{
+     tokio_tungstenite::tungstenite::http::uri::Scheme,
+     Body, HttpContext, HttpHandler, Proxy, RequestOrResponse,
+ };
++use hyper::Method;
+ use hyper::{StatusCode, Uri};
+ use hyper_rustls::{HttpsConnector, HttpsConnectorBuilder};
+ use hyper_util::{
+@@ -137,11 +139,15 @@ impl HttpHandler for Handler {
+                             "GET" | "POST" | "HEAD" => {
+                                 let original_url = req.uri().clone();
+                                 println!("{req:?}");
+-                                let Ok(req) = decode_request(req) else {
++                                let Ok(mut req) = decode_request(req) else {
+                                     let mut res = Response::new("not found".into());
+                                     *res.status_mut() = StatusCode::NOT_FOUND;
+                                     return res.into();
+                                 };
++                                let is_head_request = req.method() == "HEAD";
++                                if is_head_request {
++                                    *req.method_mut() = Method::GET;
++                                }
+                                 let (info, body) = req.into_parts();
+                                 let Ok(req_body) = body.collect().await.map(|x| x.to_bytes())
+                                 else {
+@@ -165,7 +171,7 @@ impl HttpHandler for Handler {
+                                         req_body
+                                     )])),
+                                 );
+-                                let store_body_info = req.method() != "HEAD";
++                                let store_body_info = true;
+                                 let url = process_uri(original_url);
+                                 if matches!(forget_regex, Some(x) if x.is_match(&url.to_string())) {
+                                     forget = true;
+@@ -307,7 +313,20 @@ impl HttpHandler for Handler {
+                                             }
+                                         }
+                                     });
+-                                    Response::from_parts(info, ret_body)
++                                    if is_head_request {
++                                        // For HEAD requests, drain the channel
++                                        // output; otherwise rx will be dropped,
++                                        // which closes the channel and causes
++                                        // the tx.poll_ready call above to
++                                        // return an error
++                                        let mut stream = ret_body.into_data_stream();
++                                        while let Some(_) = stream.next().await {
++                                            // do nothing
++                                        }
++                                        Response::from_parts(info, Body::empty())
++                                    } else {
++                                        Response::from_parts(info, ret_body)
++                                    }
+                                 } else {
+                                     // remove hash headers to force the software to download this
+                                     // so we get sha256

gnu/packages/patches/qemu-fix-agent-paths.patch

@@ -1,46 +1,21 @@
-Allow a QEMU host to set the time and shutdown Guix guests.  Styled
-after the patch from the Nix package:
-
-https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/virtualization/qemu/fix-qemu-ga.patch
-
 diff --git a/qga/commands-posix.c b/qga/commands-posix.c
-index 6e3c15f539..eaef900b6e 100644
+index 837be51c40..d0d4d99b5e 100644
 --- a/qga/commands-posix.c
 +++ b/qga/commands-posix.c
-@@ -216,6 +216,7 @@ out:
+@@ -216,9 +216,9 @@ out:
+     return retcode;
+ }
+ 
+-#define POWEROFF_CMD_PATH "/sbin/poweroff"
+-#define HALT_CMD_PATH "/sbin/halt"
+-#define REBOOT_CMD_PATH "/sbin/reboot"
++#define POWEROFF_CMD_PATH "/run/current-system/profile/sbin/shutdown"
++#define HALT_CMD_PATH "/run/current-system/profile/sbin/halt"
++#define REBOOT_CMD_PATH "/run/current-system/profile/sbin/reboot"
+ 
  void qmp_guest_shutdown(const char *mode, Error **errp)
  {
-     const char *shutdown_flag;
-+    const char *command;
-     Error *local_err = NULL;
- 
- #ifdef CONFIG_SOLARIS
-@@ -235,16 +236,24 @@ void qmp_guest_shutdown(const char *mode, Error **errp)
-     slog("guest-shutdown called, mode: %s", mode);
-     if (!mode || strcmp(mode, "powerdown") == 0) {
-         shutdown_flag = powerdown_flag;
-+        command = "shutdown";
-     } else if (strcmp(mode, "halt") == 0) {
-         shutdown_flag = halt_flag;
-+        command = "halt";
-     } else if (strcmp(mode, "reboot") == 0) {
-         shutdown_flag = reboot_flag;
-+        command = "reboot";
-     } else {
-         error_setg(errp,
-                    "mode is invalid (valid values are: halt|powerdown|reboot");
-         return;
-     }
- 
-+    /* Try Guix’s shutdown/halt/reboot first. */
-+    char *path = g_strdup_printf("/run/current-system/profile/sbin/%s", command);
-+    execl(path, command, (char *) NULL);
-+    g_free(path);
-+
-     const char *argv[] = {"/sbin/shutdown",
- #ifdef CONFIG_SOLARIS
-                           shutdown_flag, "-g0", "-y",
-@@ -269,7 +278,7 @@ void qmp_guest_set_time(bool has_time, int64_t time_ns, Error **errp)
+@@ -295,7 +295,7 @@ void qmp_guest_set_time(bool has_time, int64_t time_ns, Error **errp)
      int ret;
      Error *local_err = NULL;
      struct timeval tv;
@@ -49,7 +24,7 @@ index 6e3c15f539..eaef900b6e 100644
  
      /* If user has passed a time, validate and set it. */
      if (has_time) {
-@@ -302,6 +311,11 @@ void qmp_guest_set_time(bool has_time, int64_t time_ns, Error **errp)
+@@ -328,6 +328,11 @@ void qmp_guest_set_time(bool has_time, int64_t time_ns, Error **errp)
       * hardware clock (RTC). */
      ga_run_command(argv, NULL, "set hardware clock to system time",
                     &local_err);

gnu/packages/patches/qemu-fix-test-virtio-version.patch

@@ -5,8 +5,8 @@ There were some discussion in <https://gitlab.com/qemu-project/qemu/-/issues/162
 
 diff --git a/tests/functional/test_virtio_version.py b/tests/functional/test_virtio_version.py
 index a5ea73237f..501545f655 100755
---- a/tests/functional/test_virtio_version.py
-+++ b/tests/functional/test_virtio_version.py
+--- a/tests/functional/x86_64/test_virtio_version.py
++++ b/tests/functional/x86_64/test_virtio_version.py
 @@ -10,6 +10,8 @@
  # This work is licensed under the terms of the GNU GPL, version 2 or
  # later.  See the COPYING file in the top-level directory.

gnu/packages/python-xyz.scm

@@ -14,7 +14,7 @@
 ;;; Copyright © 2015, 2016, 2017, 2019, 2022 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2015, 2017 Ben Woodcroft <donttrustben@gmail.com>
 ;;; Copyright © 2015, 2016 Erik Edrosa <erik.edrosa@gmail.com>
-;;; Copyright © 2015-2025 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2015-2026 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2015, 2017, 2020 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2015, 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
@@ -5309,7 +5309,7 @@ concepts.")
 (define-public python-hdf5storage
   ;; XXX: Use the latest commit containing compatability with Pytest and Python
   ;; 3.11, see: <https://github.com/frejanordsiek/hdf5storage/issues/135>.
-  ;; 
+  ;;
   ;; This package probably is sun setting, consider to remove when stops
   ;; building, see: <https://github.com/frejanordsiek/hdf5storage/issues/136>.
   (let ((commit "7ee2a96de134b44beaa79c3a11c559f9ac87c5a6")
@@ -11033,6 +11033,15 @@ writing C extensions for Python as easy as Python itself.")
                 ;; Relay on python from the PATH instead of full reference
                 ;; stored in built wheel.
                 (("'py.full_path\\(\\)'") "'python'"))))
+          ;; This isn't architecture specific.
+          ;; TODO: Remove this conditional and apply for all builds.
+          #$@(if (target-ppc64le?)
+                 #~((add-after 'unpack 'patch-bin-true
+                      (lambda* (#:key inputs #:allow-other-keys)
+                        (substitute* "numpy/_core/tests/test_cpu_features.py"
+                          (("/bin/true")
+                           (search-input-file inputs "bin/true"))))))
+                 #~())
           (add-before 'build 'parallelize-build
             (lambda _
               (setenv "OMP_NUM_THREAD"

gnu/packages/rust-apps.scm

@@ -1976,7 +1976,8 @@ specified image or color, easing the process of theme creation.")
                      (commit (string-append "v" version))))
               (file-name (git-file-name name version))
               (sha256
-               (base32 "0hbjzf3jb8gpisq3qi5z7wc20hawcgvjwnw2xp80bwq1cj12d3vr"))))
+               (base32 "0hbjzf3jb8gpisq3qi5z7wc20hawcgvjwnw2xp80bwq1cj12d3vr"))
+              (patches (search-patches "mitm-cache-head-requests.patch"))))
     (build-system cargo-build-system)
     (arguments
      '(#:install-source? #f))

gnu/packages/rust.scm

@@ -2024,9 +2024,6 @@ ar = \"" (search-input-file inputs (string-append "/bin/" #$(ar-for-target targe
            (package-propagated-inputs base-rust)))
       (native-inputs
        (modify-inputs (package-native-inputs base-rust)
-         ;; Build with the same version as the cross-gcc version.
-         ;; TODO: Remove this when gcc and %xgcc are the same version again.
-         (prepend gcc-14)
          (prepend (cross-gcc target
                              #:libc (cross-libc target)))
          (prepend (if (target-mingw? target)

gnu/packages/sycl.scm

@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2023, 2024 Andy Tai <atai@atai.org>
+;;; Copyright © 2025, 2026 Cayetano Santos <csantosb@inventati.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -51,57 +52,45 @@
                (base32
                 "0sv5f366ybzpsdpka0fb578pb4q3537h6hkn825m0kbssh32wxk7"))))
     (build-system cmake-build-system)
-    ;; Sync with llvm-for-rocm llvm release.
-    (native-inputs (list clang-19 lld-19 python-minimal))
+    ;; Sync with llvm version used by llvm-rocm.
+    (native-inputs (list clang-20 lld-20 python-minimal))
     (inputs
      (list boost
            libffi
            numactl
            rocm-opencl-runtime
+           rocm-device-libs
+           rocm-hip-runtime
+           rocr-runtime
            spirv-headers
            spirv-tools))
     (arguments
      (list
       #:configure-flags
       #~(list
-         "-DACPP_COMPILER_FEATURE_PROFILE=full"
+         (string-append "-DCMAKE_EXE_LINKER_FLAGS=" "-Wl,-rpath="
+                        #$output "/lib,-rpath="
+                        #$output "/lib/hipSYCL/llvm-to-backend")
          (string-append
-          "-DACPP_LLD_PATH=" (search-input-file %build-inputs "/bin/ld.lld")))
-      #:phases
-      #~(modify-phases %standard-phases
-          ;; FIXME: There is probably a much better way.
-          ;; This file: bin/hipSYCL/llvm-to-backend/llvm-to-host-tool
-          ;; requires libacpp-common.so and libllvm-to-{backend,host}.so
-          ;; in RUNPATH
-          (add-before 'validate-runpath 'create-symlinks
-            (lambda _
-              (symlink
-               (string-append #$output "/lib/libacpp-common.so")
-               (string-append
-                #$output
-                "/bin/hipSYCL/llvm-to-backend/libacpp-common.so"))
-              (symlink
-               (string-append
-                #$output
-                "/lib/hipSYCL/llvm-to-backend/libllvm-to-backend.so")
-               (string-append
-                #$output
-                "/bin/hipSYCL/llvm-to-backend/libllvm-to-backend.so"))
-              (symlink
-               (string-append
-                #$output
-                "/lib/hipSYCL/llvm-to-backend/libllvm-to-host.so")
-               (string-append
-                #$output
-                "/bin/hipSYCL/llvm-to-backend/libllvm-to-host.so")))))
+          "-DACPP_LLD_PATH=" (search-input-file %build-inputs "/bin/ld.lld"))
+         "-DWITH_ROCM_BACKEND=ON"
+         (string-append
+          "-DROCM_PATH=" #$(this-package-input "rocm-device-libs"))
+         (string-append
+          "-DROCM_DEVICE_LIBS_PATH=" #$(this-package-input "rocm-device-libs")
+          "/amdgcn/bitcode"))
       #:tests? #f)) ; no tests
     (home-page "https://adaptivecpp.github.io/")
     (synopsis
-     "Implementation of the SYCL programming language for accelerators")
+     "Compiler for multiple programming models for CPUs and GPUs")
     (description
-     "AdaptiveCpp is aImplementation of SYCL and C++ standard parallelism
-for CPUs and GPUs from all vendors, with independent, community-driven
-compiler for C++-based heterogeneous programming models")
+     "AdaptiveCpp is a community-driven compiler for C++-based heterogeneous
+programming models.  It implements SYCL, C++ standard parallelism, and
+HIP/CUDA, targeting CPUs and GPUs from all major vendors.  AdaptiveCpp lets
+applications adapt themselves to all the hardware found in the system.  This
+includes use cases where a single binary needs to be able to target all
+supported hardware, or utilize hardware from different vendors
+simultaneously.")
     (license license:bsd-2)))
 
 (define-deprecated-package opensycl

gnu/packages/virtualization.scm

@@ -15,7 +15,7 @@
 ;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020, 2021, 2022 Marius Bakke <marius@gnu.org>
-;;; Copyright © 2020-2025 Maxim Cournoyer <maxim@guixotic.coop>
+;;; Copyright © 2020-2026 Maxim Cournoyer <maxim@guixotic.coop>
 ;;; Copyright © 2020 Brett Gilio <brettg@gnu.org>
 ;;; Copyright © 2021 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2021, 2022 Pierre Langlois <pierre.langlois@gmx.com>
@@ -201,14 +201,14 @@
     ;; Do not forget to update the various firmware used by QEMU, and sync the
     ;; configuration options used by the seabios-qemu package with those
     ;; provided by QEMU.
-    (version "10.1.0")
+    (version "10.2.0")
     (source
      (origin
        (method url-fetch)
        (uri (string-append "https://download.qemu.org/qemu-"
                            version ".tar.xz"))
        (sha256
-        (base32 "0ldyh3qia7zwv0xq6f67cp567i6ma1hb11gsqaz3x9qcnm4p6lg0"))
+        (base32 "0fl8hlkngmm61h65822xxb6cyfbz56mx30hm01il8ywzicdssc4y"))
        (patches (search-patches "qemu-build-info-manual.patch"
                                 "qemu-fix-agent-paths.patch"
                                 "qemu-fix-test-virtio-version.patch"))

gnu/packages/xdisorg.scm

@@ -1937,6 +1937,27 @@ night to daytime temperature to allow your eyes to slowly adapt.  At night the
 color temperature should be set to match the lamps in your room.")
     (license license:gpl3+)))
 
+(define-public wayout
+  (package
+    (name "wayout")
+    (version "0.1.5")
+    (home-page "https://git.sr.ht/~proycon/wayout")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference (url home-page) (commit version)))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "1i7bab1dcdyybwarhy44xawb6661zv4z8rfdicjyljg320vj79a2"))))
+    (build-system meson-build-system)
+    (native-inputs (list cmake-minimal pkg-config scdoc))
+    (inputs (list cairo pango wayland wayland-protocols))
+    (synopsis "Output simple text to a wayland desktop widget")
+    (description
+     "Wayout takes text from standard input and outputs it to a desktop-widget
+on Wayland desktops.")
+    (license license:gpl3+)))
+
 (define-public redshift-wayland
   (let ((commit "7da875d34854a6a34612d5ce4bd8718c32bec804")
         (revision "1"))

gnu/services/ssh.scm

@@ -70,6 +70,17 @@
             dropbear-service-type
             dropbear-service  ; deprecated
 
+            endlessh-configuration
+            endlessh-configuration?
+            endlessh-configuration-endlessh
+            endlessh-configuration-port-number
+            endlessh-configuration-log-level
+            endlessh-configuration-syslog-output?
+            endlessh-configuration-message-delay
+            endlessh-configuration-max-banner-length
+            endlessh-configuration-max-clients
+            endlessh-service-type
+
             autossh-configuration
             autossh-configuration?
             autossh-service-type
@@ -523,6 +534,68 @@ daemon} with the given @var{config}, a @code{<dropbear-configuration>}
 object."
   (service dropbear-service-type config))
 
+
+;;;
+;;; Endlessh.
+;;;
+
+(define-record-type* <endlessh-configuration>
+  endlessh-configuration make-endlessh-configuration
+  endlessh-configuration?
+  (endlessh               endlessh-configuration-endlessh
+                          (default endlessh))
+  (port-number            endlessh-configuration-port-number
+                          (default 22))
+  (log-level              endlessh-configuration-log-level
+                          (default 1))
+  (syslog-output?         endlessh-configuration-syslog-output?
+                          (default #t))
+  (message-delay          endlessh-configuration-message-delay
+                          (default 10000))
+  (max-banner-length      endlessh-configuration-max-banner-length
+                          (default 32))
+  (max-clients            endlessh-configuration-max-clients
+                          (default 4096)))
+
+(define (endlessh-shepherd-service config)
+  "Return a <shepherd-service> for endlessh with CONFIG."
+  (define endlessh
+    (endlessh-configuration-endlessh config))
+
+  (define endlessh-config
+    (format #f "Port ~a~%Delay ~a~%MaxLineLength ~a~%MaxClients ~a~%LogLevel ~a"
+            (endlessh-configuration-port-number config)
+            (endlessh-configuration-message-delay config)
+            (endlessh-configuration-max-banner-length config)
+            (endlessh-configuration-max-clients config)
+            (endlessh-configuration-log-level config)))
+
+  (define endlessh-command
+    #~(list (string-append #$endlessh "/bin/endlessh")
+            "-f" #$(plain-file "endlessh_config" endlessh-config)
+            #$@(if (endlessh-configuration-syslog-output? config) '("-s") '())))
+
+  (define requires
+    (if (endlessh-configuration-syslog-output? config)
+        '(user-processes networking syslogd)
+        '(user-processes networking)))
+
+  (list (shepherd-service
+          (documentation "EndleSSH server.")
+          (requirement requires)
+          (provision '(endlessh))
+          (start #~(make-forkexec-constructor #$endlessh-command))
+          (stop #~(make-kill-destructor)))))
+
+(define endlessh-service-type
+  (service-type (name 'endlessh)
+                (description
+                 "Run the EndleSSH secure shell (SSH) tarpit.")
+                (extensions
+                 (list (service-extension shepherd-root-service-type
+                                          endlessh-shepherd-service)))
+                (default-value (endlessh-configuration))))
+
 
 ;;;
 ;;; AutoSSH.

gnu/system/linux-container.scm

@@ -45,7 +45,11 @@
   #:export (system-container
             containerized-operating-system
             container-script
-            eval/container))
+            eval/container)
+  ;; Re-export some variables from (guix build linux-container), for
+  ;; convenience.
+  #:re-export (%namespaces
+               %writable-/tmp))
 
 (define* (container-essential-services os #:key shared-network?)
   "Return a list of essential services corresponding to OS, a

guix/build/download-nar.scm

@@ -22,6 +22,7 @@
   #:autoload   (lzlib) (call-with-lzip-input-port)
   #:use-module (guix progress)
   #:use-module (web uri)
+  #:use-module (web response)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 format)
@@ -69,7 +70,7 @@ item.  Return #t on success, #f otherwise."
       ((url rest ...)
        (format #t "Trying content-addressed mirror at ~a...~%"
                (uri-host (string->uri url)))
-       (let-values (((port size)
+       (let-values (((port response)
                      (catch #t
                        (lambda ()
                          (http-fetch (string->uri url)))
@@ -81,7 +82,7 @@ item.  Return #t on success, #f otherwise."
                          (values #f #f)))))
          (if (not port)
              (loop rest)
-             (begin
+             (let ((size (response-content-length response)))
                (if size
                    (format #t "Downloading from ~a (~,2h MiB)...~%" url
                            (/ size (expt 2 20.)))

guix/build/download.scm

@@ -22,6 +22,7 @@
 (define-module (guix build download)
   #:use-module (web uri)
   #:use-module (web http)
+  #:use-module (web response)
   #:use-module ((web client) #:hide (open-socket-for-uri))
   #:use-module (web response)
   #:use-module (guix base64)
@@ -752,7 +753,7 @@ otherwise simply ignore them."
     (case (uri-scheme uri)
       ((http https)
        (false-if-exception*
-        (let-values (((port size)
+        (let-values (((port response)
                       (http-fetch uri
                                   #:verify-certificate? verify-certificate?
                                   #:timeout timeout)))
@@ -762,9 +763,13 @@ otherwise simply ignore them."
                           #:buffer-size %http-receive-buffer-size
                           #:reporter (if print-build-trace?
                                          (progress-reporter/trace
-                                          file (uri->string uri) size)
+                                          file (uri->string uri)
+                                          (response-content-length
+                                           response))
                                          (progress-reporter/file
-                                          (uri-abbreviation uri) size)))
+                                          (uri-abbreviation uri)
+                                          (response-content-length
+                                           response))))
               (newline)))
           (close-port port)
           file)))

guix/http-client.scm

@@ -54,6 +54,8 @@
             http-get-error-reason
             http-get-error-headers
 
+            network-error?
+
             http-fetch
             http-multiple-get
 
@@ -75,6 +77,27 @@
   (reason   http-get-error-reason)                ;string
   (headers  http-get-error-headers))              ;alist
 
+(define kind-and-args-exception?
+  (exception-predicate &exception-with-kind-and-args))
+
+(define (system-error? exception)
+  "Return true if EXCEPTION is a Guile 'system-error exception."
+  (and (kind-and-args-exception? exception)
+       (eq? 'system-error (exception-kind exception))))
+
+(define network-error?
+  (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args)))
+    (lambda (exception)
+      "Return true if EXCEPTION denotes a networking error."
+      (or (and (system-error? exception)
+               (let ((errno (system-error-errno
+                             (cons 'system-error (exception-args exception)))))
+                 (memv errno (list ECONNRESET ECONNABORTED ETIMEDOUT
+                                   ECONNREFUSED EHOSTUNREACH EPIPE
+                                   ENOENT))))     ;for "file://"
+          (and (kind-and-args? exception)
+               (memq (exception-kind exception)
+                     '(gnutls-error getaddrinfo-error)))))))
 
 (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
                      (open-connection guix:open-connection-for-uri)
@@ -83,11 +106,11 @@
                      (headers '((user-agent . "GNU Guile")))
                      (log-port (current-error-port))
                      timeout)
-  "Return an input port containing the data at URI, and the expected number of
-bytes available or #f.  If TEXT? is true, the data at URI is considered to be
-textual.  Follow any HTTP redirection.  When BUFFERED? is #f, return an
-unbuffered port, suitable for use in `filtered-port'.  HEADERS is an alist of
-extra HTTP headers.
+  "Return an input port containing the data at URI, and the HTTP response from
+the server.  If TEXT? is true, the data at URI is considered to be textual.
+Follow any HTTP redirection.  When BUFFERED? is #f, return an unbuffered port,
+suitable for use in `filtered-port'.  HEADERS is an alist of extra HTTP
+headers.
 
 When KEEP-ALIVE? is true, the connection is marked as 'keep-alive' and PORT is
 not closed upon completion.
@@ -126,7 +149,7 @@ Raise an '&http-get-error' condition if downloading fails."
                      (response-code resp)))
         (case code
           ((200)
-           (values data (response-content-length resp)))
+           (values data resp))
           ((301                                   ; moved permanently
             302                                   ; found (redirection)
             303                                   ; see other

guix/import/utils.scm

@@ -202,24 +202,28 @@ thrown."
       ;; Fallback.
       (string-suffix? ".git" url)))
 
-(define (download-git-repository url ref)
+(define* (download-git-repository url ref #:key recursive?)
   "Fetch the given REF from the Git repository at URL.  Return three values :
 the commit hash, the downloaded directory and its content hash."
   (with-store store
     (let (((values checkout commit-hash)
-           (latest-repository-commit store url #:ref ref)))
+           (latest-repository-commit store url #:ref ref
+                                     #:recursive? recursive?)))
       (values commit-hash
               checkout
               (bytevector->nix-base32-string
                (query-path-hash store checkout))))))
 
-(define (git-origin url commit hash)
+(define* (git-origin url commit hash #:key recursive?)
   "Simple helper to generate a Git origin s-expression."
   `(origin
      (method git-fetch)
      (uri (git-reference
             (url ,(and (not (eq? url 'null)) url))
-            (commit ,commit)))
+            (commit ,commit)
+            ,@(if recursive?
+                  '(recursive? #t)
+                  '())))
      (file-name (git-file-name name version))
      (sha256
       (base32 ,hash))))

guix/remote-procedures.scm

@@ -0,0 +1,364 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012-2025 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix remote-procedures)
+  #:use-module (guix serialization)
+  #:export (%protocol-version
+            %worker-magic-1
+            %worker-magic-2
+            protocol-major
+            protocol-minor
+            protocol-version
+
+            visit-remote-procedures
+            id:
+            returns:
+            remote-procedure-id
+            stream-argument
+
+            hash-algo
+            build-mode
+            gc-action))
+
+;;; Comment:
+;;;
+;;; This module defines the remote procedure interface between the build
+;;; daemon and clients (also known as "remote procedure calls" or RPCs).  It
+;;; is used to generate client stubs in (guix store) and can also be used to
+;;; generate server stubs.
+;;;
+;;; Code:
+
+(define %protocol-version
+  ;; Version of the currently-implemented protocol.
+  #x164)
+
+;; Values sent by the client and then the server upon handshake.
+(define %worker-magic-1 #x6e697863)               ; "nixc"
+(define %worker-magic-2 #x6478696f)               ; "dxio"
+
+(define (protocol-major magic)
+  "Extract from MAGIC, an integer, the protocol major version."
+  (logand magic #xff00))
+
+(define (protocol-minor magic)
+  "Extract from MAGIC, an integer, the protocol minor version."
+  (logand magic #x00ff))
+
+(define (protocol-version major minor)
+  "Return an integer representing protocol version MAJOR and MINOR."
+  (logior major minor))
+
+(define-syntax define-remote-procedures
+  (syntax-rules (define)
+    ((_ walk definition ...)
+     (define-syntax-rule (walk process)
+       (process definition ...)))))
+
+;; Syntactic keywords.
+(define-syntax id:
+  (lambda (s) #`(syntax-error "invalid use of 'id:' keyword" #,s)))
+(define-syntax returns:
+  (lambda (s) #`(syntax-error "invalid use of 'returns:' keyword" #,s)))
+
+;; What follows is in essence an instance of the interface definition language
+;; (IDL) for client/daemon messaging.
+(define-remote-procedures visit-remote-procedures
+
+  (define (valid-path? (utf8-string path))
+    "Return #t when PATH designates a valid store item and #f otherwise (an
+invalid item may exist on disk but still be invalid, for instance because it
+is the result of an aborted or failed build.)
+
+An exception is raised if PATH is not prefixed by the store
+directory (/gnu/store)."
+    id: 1
+    returns: boolean)
+
+  (define (has-substitutes? (store-path path))    ;deprecated
+    "Return #t if binary substitutes are available for PATH, and #f
+otherwise."
+    id: 3
+    returns: boolean)
+
+  (define (query-path-hash (store-path path))
+    "Return the SHA256 hash of the nar serialization of PATH as a bytevector."
+    id: 4
+    returns: base16)
+
+  (define (query-references (store-path path))
+    "Return the list of references of PATH."
+    id: 5
+    returns: store-path-list)
+
+  (define (query-referrers (store-path path))
+    "Return the list of store items that refer to PATH."
+    id: 6
+    returns: store-path-list)
+
+  (define (add-to-store (utf8-string basename)
+                        (boolean obsolete)        ;obsolete, must be #t
+                        (boolean recursive?)
+                        (utf8-string hash-algo)
+                        (file file-name))
+    "Add the contents of FILE-NAME under BASENAME to the store.  When
+RECURSIVE? is false, FILE-NAME must designate a regular file--not a directory
+nor a symlink.  When RECURSIVE? is true and FILE-NAME designates a directory,
+the contents of FILE-NAME are added recursively; if FILE-NAME designates a
+flat file and RECURSIVE? is true, its contents are added, and its permission
+bits are kept.  HASH-ALGO must be a string such as \"sha256\".
+
+When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
+where FILE is the entry's absolute file name and STAT is the result of
+'lstat'; exclude entries for which SELECT? does not return true.
+
+Return the store file name of the newly added file."
+    id: 7
+    returns: store-path)
+
+  (define (add-text-to-store (utf8-string name) (bytevector text)
+                             (string-list references))
+    "Add BYTES under file NAME in the store, and return its store path.
+REFERENCES is the list of store paths referred to by the resulting store
+path."
+    id: 8
+    returns: store-path)
+
+  (define (build-things (string-list things)
+                        (integer mode))
+    "Build THINGS, a list of store items which may be either '.drv' files or
+outputs, and return when the worker is done building them.  Elements of THINGS
+that are not derivations can only be substituted and not built locally.
+Alternatively, an element of THING can be a derivation/output name pair, in
+which case the daemon will attempt to substitute just the requested output of
+the derivation.  Return #t on success."
+    id: 9
+    returns: boolean)
+
+  (define (ensure-path (store-path path))
+    "Ensure that the given path is valid; if it is not valid, it may be made valid
+by running a substitute.  Return #t on success and raise an exception on
+failure.
+
+As a GC root is not created by the daemon, you may want to call
+'add-temp-root' on that store path."
+    id: 10
+    returns: boolean)
+
+  (define (add-temp-root (store-path path))
+    "Make PATH a temporary root for the duration of the current session.
+Return #t."
+    id: 11
+    returns: boolean)
+
+  (define (add-indirect-root (utf8-string file-name))
+    "Make the symlink FILE-NAME an indirect root for the garbage collector:
+whatever store item FILE-NAME points to will not be collected.  Return #t on
+success.
+
+FILE-NAME can be anywhere on the file system, but it must be an absolute file
+name--it is the caller's responsibility to ensure that it is an absolute file
+name."
+    id: 12
+    returns: boolean)
+
+  (define (find-roots)
+    "Return a list of root/target pairs: for each pair, the first element is the
+GC root file name and the second element is its target in the store.
+
+When talking to a local daemon, this operation is equivalent to the 'gc-roots'
+procedure in (guix store roots), except that the 'find-roots' excludes
+potential roots that do not point to store items."
+    id: 14
+    returns: string-pairs)
+
+  (define (export-path (store-path item)
+                       (boolean sign?)
+                       (stream port))
+    "Export PATH to PORT; when SIGN? is true, sign it.  Return #t."
+    id: 16
+    returns: boolean)
+
+  (define (set-options (boolean keep-failed?) (boolean keep-going?)
+                       (boolean fallback?) (integer verbosity)
+                       (boolean offload?)
+                       (integer build-verbosity) (integer log-type)
+                       (boolean print-build-trace)
+                       (boolean use-substitutes?)
+                       (string-pairs settings))
+    "Set daemon options for this session; return nothing."
+    id: 19
+    returns:)                                     ;returns nothing
+
+  (define (collect-garbage (integer action)
+                           (store-path-list to-delete)
+                           (boolean obsolete1)
+                           (long-long min-freed)
+                           (integer obsolete2)
+                           (integer obsolete3)
+                           (integer obsolete4))
+    "Invoke the garbage collector to perform ACTION, a 'gc-action' value."
+    id: 20
+    returns: store-path-list long-long long-long)
+
+  (define (query-derivation-outputs ;avoid name clash with `derivation-outputs'
+           (store-path path))
+    "Return the list of outputs of PATH, a .drv file."
+    id: 22
+    returns: store-path-list)
+
+  ;; missing: query-all-valid-paths id: 23
+
+  (define (query-failed-paths)
+    "Return the list of store items for which a build failure is cached.
+
+The result is always the empty list unless the daemon was started with
+'--cache-failures'."
+    id: 24
+    returns: store-path-list)
+
+  (define (clear-failed-paths (store-path-list items))
+    "Remove ITEMS from the list of cached build failures and return #t.
+
+This makes sense only when the daemon was started with '--cache-failures'."
+    id: 25
+    returns: boolean)
+
+  (define (query-path-info (store-path path))
+    "Return the info (hash, references, etc.) for PATH."
+    id: 26
+    returns: path-info)
+
+  (define (import-paths (stream port))
+    "Import the set of store paths read from PORT into SERVER's store.  An error
+is raised if the set of paths read from PORT is not signed (as per
+'export-path #:sign? #t'.)  Return the list of store paths imported."
+    id: 27
+    returns: store-path-list)
+
+  (define (query-path-from-hash-part (utf8-string hash))
+    "Return the store path whose hash part is HASH-PART (a nix-base32
+string).  Return the empty string if no such path exists."
+    ;; This RPC is primarily used by Hydra to reply to HTTP GETs of
+    ;; /HASH.narinfo.
+    id: 29
+    returns: store-path)
+
+  (define (query-substitutable-paths (store-path-list paths))
+    "Return the subset of PATHS that is substitutable."
+    id: 32
+    returns: store-path-list)
+
+  (define (query-valid-derivers (store-path path))
+    "Return the list of valid \"derivers\" of PATH---i.e., all the
+.drv present in the store that have PATH among their outputs."
+    id: 33
+    returns: store-path-list)
+
+  (define (query-substitutable-path-infos (store-path-list paths))
+    "Return information about the subset of PATHS that is
+substitutable.  For each substitutable path, a `substitutable?' object is
+returned; thus, the resulting list can be shorter than PATHS.  Furthermore,
+that there is no guarantee that the order of the resulting list matches the
+order of PATHS."
+    id: 30
+    returns: substitutable-path-list)
+
+  (define (optimize-store)
+    "Optimize the store by hard-linking identical files (\"deduplication\".)
+Return #t on success."
+    id: 34
+    returns: boolean)
+
+  (define (verify-store (boolean check-contents?)
+                        (boolean repair?))
+    "Verify the store.  Return #t if errors were encountered, false otherwise."
+    id: 35
+    returns: boolean)
+
+  ;; Guix-specific RPCs.
+
+  (define (built-in-builders)
+    "Return the built-in builders."
+    id: 80
+    returns: string-list)
+
+  (define (substitute-urls)
+    "Return the list of substitute URLs."
+    id: 81
+    returns: string-list))
+
+(define-syntax remote-procedure-id
+  (syntax-rules ()
+    "Return the numeric identifier of the remote procedure with the given name."
+    ((_ name)
+     (letrec-syntax ((extract-id
+                      (lambda (s)
+                        (syntax-case s (define id: returns:)
+                          ((_)
+                           #`(syntax-error "remote procedure not found"
+                                           #,s))
+                          ((_ (define (procedure formals (... ...))
+                                doc
+                                id: id
+                                returns: _ (... ...))
+                              rest (... ...))
+                           (eq? (syntax->datum #'procedure)
+                                (syntax->datum #'name))
+                           #'id)
+                          ((_ (define _ (... ...))
+                              rest (... ...))
+                           #'(extract-id rest (... ...)))))))
+       (visit-remote-procedures extract-id)))))
+
+(define-syntax stream-argument
+  (syntax-rules (stream)
+    "Extract the stream from the given formal parameter list, or expand to #f
+if there is none."
+    ((_ (stream arg) rest ...)
+     arg)
+    ((_ (type arg) rest ...)
+     (stream-argument rest ...))
+    ((_)
+     #f)))
+
+(define-syntax define-enumerate-type
+  (syntax-rules ()
+    ((_ name->int (name id) ...)
+     (define-syntax name->int
+       (syntax-rules (name ...)
+         ((_ name) id) ...)))))
+
+(define-enumerate-type hash-algo
+  ;; hash.hh
+  (md5 1)
+  (sha1 2)
+  (sha256 3))
+
+(define-enumerate-type build-mode
+  ;; store-api.hh
+  (normal 0)
+  (repair 1)
+  (check 2))
+
+(define-enumerate-type gc-action
+  ;; store-api.hh
+  (return-live 0)
+  (return-dead 1)
+  (delete-dead 2)
+  (delete-specific 3))

guix/scripts/challenge.scm

@@ -44,6 +44,7 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 ftw)
   #:use-module (web uri)
+  #:use-module (web response)
   #:export (compare-contents
 
             comparison-report?
@@ -257,11 +258,14 @@ in the nar."
   "Call PROC with an input port from which it can read the nar pointed to by
 NARINFO."
   (let* ((uri compression size (narinfo-best-uri narinfo))
-         (port actual-size     (http-fetch uri)))
+         (port response        (http-fetch uri)))
     (define reporter
       (progress-reporter/file (narinfo-path narinfo)
                               (and size
-                                   (max size (or actual-size 0))) ;defensive
+                                   (max size (or
+                                              (response-content-length
+                                               response)
+                                              0))) ;defensive
                               #:abbreviation (const (uri-host uri))))
 
     (define result

guix/scripts/substitute.scm

@@ -31,7 +31,6 @@
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
   #:use-module ((guix serialization) #:select (restore-file dump-file))
-  #:autoload   (guix store deduplication) (dump-file/deduplicate)
   #:autoload   (guix scripts discover) (read-substitute-urls)
   #:use-module (gcrypt hash)
   #:use-module (guix base32)
@@ -40,14 +39,9 @@
   #:use-module (guix pki)
   #:autoload   (guix build utils) (mkdir-p delete-file-recursively)
   #:use-module ((guix build download)
-                #:select (uri-abbreviation nar-uri-abbreviation
+                #:select (uri-abbreviation
                           (open-connection-for-uri
                            . guix:open-connection-for-uri)))
-  #:autoload   (gnutls) (error/invalid-session
-                         error/again
-                         error/interrupted
-                         error/push-error
-                         error/pull-error)
   #:use-module (guix progress)
   #:use-module ((guix build syscalls)
                 #:select (set-thread-name))
@@ -61,6 +55,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-71)
   #:use-module (web uri)
+  #:use-module (web response)
   #:use-module (guix http-client)
   #:export (%allow-unauthenticated-substitutes?
             %reply-file-descriptor
@@ -95,45 +90,6 @@ disabled!~%"))
    (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
           (cut string-ci=? <> "yes"))))
 
-(define %fetch-timeout
-  ;; Number of seconds after which networking is considered "slow".
-  5)
-
-(define %random-state
-  (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
-
-(define-syntax-rule (with-timeout duration handler body ...)
-  "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
-again."
-  (begin
-    (sigaction SIGALRM
-      (lambda (signum)
-        (sigaction SIGALRM SIG_DFL)
-        handler))
-    (alarm duration)
-    (call-with-values
-        (lambda ()
-          (let try ()
-            (catch 'system-error
-              (lambda ()
-                body ...)
-              (lambda args
-                ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
-                ;; because of the bug at
-                ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
-                ;; When that happens, try again.  Note: SA_RESTART cannot be
-                ;; used because of <http://bugs.gnu.org/14640>.
-                (if (= EINTR (system-error-errno args))
-                    (begin
-                      ;; Wait a little to avoid bursts.
-                      (usleep (random 3000000 %random-state))
-                      (try))
-                    (apply throw args))))))
-      (lambda result
-        (alarm 0)
-        (sigaction SIGALRM SIG_DFL)
-        (apply values result)))))
-
 (define (at-most max-length lst)
   "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
 return its MAX-LENGTH first elements and its tail."
@@ -266,22 +222,20 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
 ;;; Daemon/substituter protocol.
 ;;;
 
-(define %prefer-fast-decompression?
-  ;; Whether to prefer fast decompression over good compression ratios.  This
-  ;; serves in particular to choose between lzip (high compression ratio but
-  ;; low decompression throughput) and zstd (lower compression ratio but high
-  ;; decompression throughput).
-  #f)
+;; Whether to initially prefer fast decompression or not
+(define %default-fast-decompression? #t)
 
-(define (call-with-cpu-usage-monitoring proc)
+(define (call-with-cpu-usage-monitoring thunk)
   (let ((before (times)))
-    (proc)
-    (let ((after (times)))
-      (if (= (tms:clock after) (tms:clock before))
-          0
-          (/ (- (tms:utime after) (tms:utime before))
-             (- (tms:clock after) (tms:clock before))
-             1.)))))
+    (call-with-values thunk
+      (lambda vals
+        (let* ((after (times))
+               (usage (if (= (tms:clock after) (tms:clock before))
+                          0
+                          (/ (- (tms:utime after) (tms:utime before))
+                             (- (tms:clock after) (tms:clock before))
+                             1.))))
+          (apply values (append vals (list usage))))))))
 
 (define-syntax-rule (with-cpu-usage-monitoring exp ...)
   "Evaluate EXP...  Return its CPU usage as a fraction between 0 and 1."
@@ -302,7 +256,7 @@ daemon."
   (let ((uri compression file-size
              (narinfo-best-uri narinfo
                                #:fast-decompression?
-                               %prefer-fast-decompression?)))
+                               %default-fast-decompression?)))
     (format port "~a\n~a\n"
             (or file-size 0)
             (or (narinfo-size narinfo) 0))))
@@ -365,6 +319,10 @@ authorized substitutes."
   ;; 'open-connection-for-uri/cached'.
   16)
 
+(define %fetch-timeout
+  ;; Number of seconds after which networking is considered "slow".
+  5)
+
 (define open-connection-for-uri/cached
   (let ((cache '()))
     (lambda* (uri #:key fresh? (timeout %fetch-timeout) verify-certificate?)
@@ -410,237 +368,10 @@ server certificates."
                     (drain-input socket)
                     socket))))))))
 
-(define kind-and-args-exception?
-  (exception-predicate &exception-with-kind-and-args))
-
-(define (call-with-cached-connection uri proc)
-  (let ((port (open-connection-for-uri/cached uri
-                                              #:verify-certificate? #f)))
-    (guard (c ((kind-and-args-exception? c)
-               (let ((key (exception-kind c))
-                     (args (exception-args c)))
-                 ;; If PORT was cached and the server closed the connection in the
-                 ;; meantime, we get EPIPE.  In that case, open a fresh connection
-                 ;; and retry.  We might also get 'bad-response or a similar
-                 ;; exception from (web response) later on, once we've sent the
-                 ;; request, or a ERROR/INVALID-SESSION from GnuTLS.
-                 (if (or (and (eq? key 'system-error)
-                              (= EPIPE (system-error-errno `(,key ,@args))))
-                         (and (eq? key 'gnutls-error)
-                              (memq (first args)
-                                    (list error/invalid-session
-
-                                          ;; "Error in the push function" is
-                                          ;; usually a transient error.
-                                          error/push-error
-                                          error/pull-error
-
-                                          ;; XXX: These two are not properly handled in
-                                          ;; GnuTLS < 3.7.3, in
-                                          ;; 'write_to_session_record_port'; see
-                                          ;; <https://bugs.gnu.org/47867>.
-                                          error/again error/interrupted)))
-                         (memq key '(bad-response bad-header bad-header-component)))
-                     (proc (open-connection-for-uri/cached uri
-                                                           #:verify-certificate? #f
-                                                           #:fresh? #t))
-                     (raise c))))
-              (#t
-               ;; An exception that's not handled here, such as
-               ;; '&http-get-error'.  Re-raise it.
-               (raise c)))
-      (proc port))))
-
-(define-syntax-rule (with-cached-connection uri port exp ...)
-  "Bind PORT with EXP... to a socket connected to URI."
-  (call-with-cached-connection uri (lambda (port) exp ...)))
-
-(define-syntax-rule (catch-system-error exp)
-  (catch 'system-error
-    (lambda () exp)
-    (const #f)))
-
-(define* (download-nar narinfo destination
-                       #:key status-port
-                       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
-STATUS-PORT."
-  (define destination-in-store?
-    (string-prefix? (string-append (%store-prefix) "/")
-                    destination))
-
-  (define (dump-file/deduplicate* . args)
-    ;; Make sure deduplication looks at the right store (necessary in test
-    ;; environments).
-    (apply dump-file/deduplicate
-           (append args (list #:store (%store-prefix)))))
-
-  (define (fetch uri)
-    (case (uri-scheme uri)
-      ((file)
-       (let ((port (open-file (uri-path uri) "r0b")))
-         (values port (stat:size (stat port)))))
-      ((http https)
-       (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
-       (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)
-                       (or (http-get-error? c)
-                           (network-error? c)))
-                  (warning (G_ "download from '~a' failed, trying next URL~%")
-                           (uri->string uri))
-                  (try-fetch rest)))
-         (let ((port download-size (fetch uri)))
-           (unless print-build-trace?
-             (format (current-error-port)
-                     (G_ "Downloading ~a...~%") (uri->string uri)))
-           (values port uri compression download-size))))
-      (()
-       (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.
-  (catch-system-error (delete-file-recursively destination))
-
-  (let ((choices (narinfo-preferred-uris narinfo
-                                         #:fast-decompression?
-                                         %prefer-fast-decompression?)))
-    ;; 'guix publish' without '--cache' doesn't specify a Content-Length, so
-    ;; DOWNLOAD-SIZE is #f in this case.
-    (let* ((raw uri compression download-size (try-fetch choices))
-           (progress
-            (let* ((dl-size  (or download-size
-                                 (and (equal? compression "none")
-                                      (narinfo-size narinfo))))
-                   (reporter (if print-build-trace?
-                                 (progress-reporter/trace
-                                  destination
-                                  (uri->string uri) dl-size
-                                  (current-error-port))
-                                 (progress-reporter/file
-                                  (uri->string uri) dl-size
-                                  (current-error-port)
-                                  #:abbreviation nar-uri-abbreviation))))
-              ;; Keep RAW open upon completion so we can later reuse
-              ;; the underlying connection.  Pass the download size so
-              ;; that this procedure won't block reading from RAW.
-              (progress-report-port reporter raw
-                                    #:close? #f
-                                    #:download-size dl-size)))
-           (input pids
-                  ;; NOTE: This 'progress' port of current process will be
-                  ;; closed here, while the child process doing the
-                  ;; reporting will close it upon exit.
-                  (decompressed-port (string->symbol compression)
-                                     progress))
-
-           ;; Compute the actual nar hash as we read it.
-           (algorithm expected (narinfo-hash-algorithm+value narinfo))
-           (hashed get-hash (open-hash-input-port algorithm input)))
-      ;; Unpack the Nar at INPUT into DESTINATION.
-      (define cpu-usage
-        (with-cpu-usage-monitoring
-         (restore-file hashed destination
-                       #:dump-file (if (and destination-in-store?
-                                            deduplicate?)
-                                       dump-file/deduplicate*
-                                       dump-file))))
-
-      ;; Create a hysteresis: depending on CPU usage, favor compression
-      ;; methods with faster decompression (like ztsd) or methods with better
-      ;; compression ratios (like lzip).  This stems from the observation that
-      ;; substitution can be CPU-bound when high-speed networks are used:
-      ;; <https://lists.gnu.org/archive/html/guix-devel/2020-12/msg00177.html>.
-      ;; To simulate "slow" networking or changing conditions, run:
-      ;;   sudo tc qdisc add dev eno1 root tbf rate 512kbit latency 50ms burst 1540
-      ;; and then cancel with:
-      ;;   sudo tc qdisc del dev eno1 root
-      (when (> cpu-usage .8)
-        (set! %prefer-fast-decompression? #t))
-      (when (< cpu-usage .2)
-        (set! %prefer-fast-decompression? #f))
-
-      (close-port hashed)
-      (close-port input)
-
-      ;; Wait for the reporter to finish.
-      (every (compose zero? cdr waitpid) pids)
-
-      ;; Skip a line after what 'progress-reporter/file' printed, and another
-      ;; one to visually separate substitutions.  When PRINT-BUILD-TRACE? is
-      ;; true, leave it up to (guix status) to prettify things.
-      (newline (current-error-port))
-      (unless print-build-trace?
-        (newline (current-error-port)))
-
-      ;; Check whether we got the data announced in NARINFO.
-      (let ((actual (get-hash)))
-        (if (bytevector=? actual expected)
-            ;; Tell the daemon that we're done.
-            (format status-port "success ~a ~a~%"
-                    (narinfo-hash narinfo) (narinfo-size narinfo))
-            ;; The actual data has a different hash than that in NARINFO.
-            (format status-port "hash-mismatch ~a ~a ~a~%"
-                    (hash-algorithm-name algorithm)
-                    (bytevector->nix-base32-string expected)
-                    (bytevector->nix-base32-string actual)))))))
-
-(define (system-error? exception)
-  "Return true if EXCEPTION is a Guile 'system-error exception."
-  (and (kind-and-args-exception? exception)
-       (eq? 'system-error (exception-kind exception))))
-
-(define network-error?
-  (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args)))
-    (lambda (exception)
-      "Return true if EXCEPTION denotes a networking error."
-      (or (and (system-error? exception)
-               (let ((errno (system-error-errno
-                             (cons 'system-error (exception-args exception)))))
-                 (memv errno (list ECONNRESET ECONNABORTED ETIMEDOUT
-                                   ECONNREFUSED EHOSTUNREACH
-                                   ENOENT))))     ;for "file://"
-          (and (kind-and-args? exception)
-               (memq (exception-kind exception)
-                     '(gnutls-error getaddrinfo-error)))
-          (http-get-error? exception)))))
-
-(define* (process-substitution/fallback port narinfo destination
+(define* (process-substitution/fallback narinfo destination
                                         #:key cache-urls acl
-                                        deduplicate? print-build-trace?)
+                                        deduplicate? print-build-trace?
+                                        fast-decompression?)
   "Attempt to substitute NARINFO, which is assumed to be authorized or
 equivalent, by trying to download its nar from each entry in CACHE-URLS.
 
@@ -652,9 +383,8 @@ way to download the nar."
   (let loop ((cache-urls cache-urls))
     (match cache-urls
       (()
-       (report-error (G_ "failed to find alternative substitute for '~a'~%")
-                     (narinfo-path narinfo))
-       (display "not-found\n" port))
+       ;; Failure, so return two values like download-nar
+       (values #f #f))
       ((cache-url rest ...)
        (match (lookup-narinfos cache-url
                                (list (narinfo-path narinfo))
@@ -664,7 +394,8 @@ way to download the nar."
           (if (or (equivalent-narinfo? narinfo alternate)
                   (valid-narinfo? alternate acl)
                   (%allow-unauthenticated-substitutes?))
-              (guard (c ((network-error? c)
+              (guard (c ((or (http-get-error? c)
+                             (network-error? c))
                          (when (http-get-error? c)
                            (warning (G_ "download from '~a' failed: ~a, ~s~%")
                                     (uri->string (http-get-error-uri c))
@@ -672,16 +403,21 @@ way to download the nar."
                                     (http-get-error-reason c)))
                          (loop rest)))
                 (download-nar alternate destination
-                              #:status-port port
                               #:deduplicate? deduplicate?
-                              #:print-build-trace? print-build-trace?))
+                              #:print-build-trace? print-build-trace?
+                              #:fast-decompression?
+                              fast-decompression?
+                              #:open-connection-for-uri
+                              open-connection-for-uri/cached
+                              #:keep-alive? #t))
               (loop rest)))
          (()
           (loop rest)))))))
 
-(define* (process-substitution port store-item destination
+(define* (process-substitution store-item destination
                                #:key cache-urls acl
-                               deduplicate? print-build-trace?)
+                               deduplicate? print-build-trace?
+                               fast-decompression?)
   "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
 DESTINATION as a nar file.  Verify the substitute against ACL, and verify its
 hash against what appears in the narinfo.  When DEDUPLICATE? is true, and if
@@ -699,25 +435,38 @@ PORT."
       (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)
-             (process-substitution/fallback port narinfo destination
-                                            #:cache-urls cache-urls
-                                            #:acl acl
-                                            #:deduplicate? deduplicate?
-                                            #:print-build-trace?
-                                            print-build-trace?)))
-    (download-nar narinfo destination
-                  #:status-port port
-                  #:deduplicate? deduplicate?
-                  #:print-build-trace? print-build-trace?)))
+  (let ((expected-hash
+         actual-hash
+         (guard
+             (c ((or (http-get-error? 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)
+                 (process-substitution/fallback narinfo destination
+                                                #:cache-urls cache-urls
+                                                #:acl acl
+                                                #:deduplicate? deduplicate?
+                                                #:print-build-trace?
+                                                print-build-trace?
+                                                #:fast-decompression?
+                                                fast-decompression?)))
+           (download-nar narinfo destination
+                         #:deduplicate? deduplicate?
+                         #:print-build-trace? print-build-trace?
+                         #:fast-decompression? fast-decompression?
+                         #:open-connection-for-uri
+                         open-connection-for-uri/cached
+                         #:keep-alive? #t))))
+    (values narinfo
+            expected-hash
+            actual-hash)))
 
 
 ;;;
@@ -907,26 +656,82 @@ default value."
         ;; Specify the number of columns of the terminal so the progress
         ;; report displays nicely.
         (parameterize ((current-terminal-columns (client-terminal-columns)))
-          (let loop ()
+          (let loop ((fast-decompression?
+                      %default-fast-decompression?))
             (match (read-line)
               ((? eof-object?)
                #t)
               ((= string-tokenize ("substitute" store-path destination))
-               (process-substitution reply-port store-path destination
-                                     #:cache-urls (substitute-urls)
-                                     #:acl (current-acl)
-                                     #:deduplicate? deduplicate?
-                                     #:print-build-trace?
-                                     print-build-trace?)
-               (loop))))))
+               (let ((narinfo
+                      expected-hash
+                      actual-hash
+                      cpu-usage
+                      (with-cpu-usage-monitoring
+                       (process-substitution
+                        store-path destination
+                        #:cache-urls (substitute-urls)
+                        #:acl (current-acl)
+                        #:deduplicate? deduplicate?
+                        #:print-build-trace?
+                        print-build-trace?
+                        #:fast-decompression?
+                        fast-decompression?))))
+
+                 (if expected-hash
+                     (begin
+                       ;; Skip a line after what 'progress-reporter/file'
+                       ;; printed, and another one to visually separate
+                       ;; substitutions.  When PRINT-BUILD-TRACE? is true,
+                       ;; leave it up to (guix status) to prettify things.
+                       (newline (current-error-port))
+                       (unless print-build-trace?
+                         (newline (current-error-port)))
+
+                       ;; Check whether we got the data announced in NARINFO.
+                       (if (bytevector=? actual-hash expected-hash)
+                           ;; Tell the daemon that we're done.
+                           (format reply-port "success ~a ~a~%"
+                                   (narinfo-hash narinfo) (narinfo-size narinfo))
+                           ;; The actual data has a different hash than that in NARINFO.
+                           (format reply-port "hash-mismatch ~a ~a ~a~%"
+                                   (hash-algorithm-name
+                                    (narinfo-hash-algorithm+value narinfo))
+                                   (bytevector->nix-base32-string expected-hash)
+                                   (bytevector->nix-base32-string actual-hash)))
+
+                       ;; Create a hysteresis: depending on CPU usage, favor
+                       ;; compression methods with faster decompression (like
+                       ;; ztsd) or methods with better compression ratios
+                       ;; (like lzip).  This stems from the observation that
+                       ;; substitution can be CPU-bound when high-speed
+                       ;; networks are used:
+                       ;; <https://lists.gnu.org/archive/html/guix-devel/2020-12/msg00177.html>.
+                       ;; To simulate "slow" networking or changing
+                       ;; conditions, run:
+                       ;;   sudo tc qdisc add dev eno1 root tbf rate 512kbit latency 50ms burst 1540
+                       ;; and then cancel with:
+                       ;;   sudo tc qdisc del dev eno1 root
+                       (loop (cond
+                              ;; Whether to prefer fast decompression over
+                              ;; good compression ratios.  This serves in
+                              ;; particular to choose between lzip (high
+                              ;; compression ratio but low decompression
+                              ;; throughput) and zstd (lower compression ratio
+                              ;; but high decompression throughput).
+                              ((> cpu-usage .8) #t)
+                              ((< cpu-usage .2) #f)
+                              (else fast-decompression?))))
+                     (begin
+                       (report-error (G_ "failed to find alternative substitute for '~a'~%")
+                                     (narinfo-path narinfo))
+                       (display "not-found\n" reply-port)
+
+                       (loop fast-decompression?)))))))))
        (opts
         (leave (G_ "~a: unrecognized options~%") opts))))))
 
 ;;; Local Variables:
-;;; eval: (put 'with-timeout 'scheme-indent-function 1)
 ;;; eval: (put 'with-redirected-error-port 'scheme-indent-function 0)
-;;; eval: (put 'with-cached-connection 'scheme-indent-function 2)
-;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1)
 ;;; End:
 
 ;;; substitute.scm ends here

guix/serialization.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-2021, 2025 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,8 +17,12 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix serialization)
+  #:autoload   (guix base16) (base16-string->bytevector
+                              bytevector->base16-string)
   #:use-module (rnrs bytevectors)
+  #:autoload   (rnrs bytevectors gnu) (bytevector-slice)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -26,17 +30,23 @@
   #:use-module ((ice-9 rdelim) #:prefix rdelim:)
   #:use-module (ice-9 match)
   #:use-module (ice-9 ftw)
-  #:use-module (system foreign)
-  #:export (write-int read-int
+  #:export (write-value
+            read-value
+            write-bytevector
+            read-maybe-utf8-string
+            (dump . dump-port*)
+
+            ;; The following bindings are exported for backward compatibility
+            ;; but one should use 'read-value' and 'write-value' instead.
+            write-int read-int
             write-long-long read-long-long
             write-padding
-            write-bytevector write-string
-            read-string read-latin1-string read-maybe-utf8-string
+            write-string
+            read-string read-latin1-string
             write-string-list read-string-list
             write-string-pairs read-string-pairs
             write-store-path read-store-path
             write-store-path-list read-store-path-list
-            (dump . dump-port*)
 
             &nar-error
             nar-error?
@@ -49,6 +59,21 @@
 
             write-file
             write-file-tree
+
+            substitutable?
+            substitutable-path
+            substitutable-deriver
+            substitutable-references
+            substitutable-download-size
+            substitutable-nar-size
+
+            path-info?
+            path-info-deriver
+            path-info-hash
+            path-info-references
+            path-info-registration-time
+            path-info-nar-size
+
             fold-archive
             restore-file
             dump-file))
@@ -81,17 +106,6 @@
                          (port port)))))
     bv))
 
-(define (sub-bytevector bv len)
-  "Return a bytevector that aliases the first LEN bytes of BV."
-  (define max (bytevector-length bv))
-  (cond ((= len max) bv)
-        ((< len max)
-         ;; Yes, this is safe because the result of each conversion procedure
-         ;; has its life cycle synchronized with that of its argument.
-         (pointer->bytevector (bytevector->pointer bv) len))
-        (else
-         (error "sub-bytevector called to get a super bytevector"))))
-
 (define (write-int n p)
   (let ((b (make-bytevector 8 0)))
     (bytevector-u32-set! b 0 n (endianness little))
@@ -101,6 +115,12 @@
   (let ((b (get-bytevector-n* p 8)))
     (bytevector-u32-ref b 0 (endianness little))))
 
+(define (write-boolean b p)
+  (write-int (if b 1 0) p))
+
+(define (read-boolean p)
+  (not (zero? (read-int p))))
+
 (define (write-long-long n p)
   (let ((b (make-bytevector 8 0)))
     (bytevector-u64-set! b 0 n (endianness little))
@@ -133,7 +153,7 @@
          (m   (modulo len 8))
          (pad (if (zero? m) 0 (- 8 m)))
          (bv  (get-bytevector-n* p (+ len pad))))
-    (sub-bytevector bv len)))
+    (bytevector-slice bv 0 len)))
 
 (define (read-string p)
   (utf8->string (read-byte-string p)))
@@ -161,6 +181,12 @@ substitute invalid byte sequences with question marks.  This is a
     (set-port-conversion-strategy! port 'substitute)
     (rdelim:read-string port)))
 
+(define (read-base16 p)
+  (base16-string->bytevector (read-string p)))
+
+(define (write-base16 bv p)
+  (write-string (bytevector->base16-string bv) p))
+
 (define (write-string-list l p)
   (write-int (length l) p)
   (for-each (cut write-string <> p) l))
@@ -229,6 +255,111 @@ any run-time allocations or computations."
                bytes)
          #`(put-bytevector port #,bv))))))
 
+;; Information about a substitutable store path.
+(define-record-type <substitutable>
+  (substitutable path deriver refs dl-size nar-size)
+  substitutable?
+  (path      substitutable-path)
+  (deriver   substitutable-deriver)
+  (refs      substitutable-references)
+  (dl-size   substitutable-download-size)
+  (nar-size  substitutable-nar-size))
+
+(define (read-substitutable-path-list p)
+  (let loop ((len    (read-int p))
+             (result '()))
+    (if (zero? len)
+        (reverse result)
+        (let ((path     (read-store-path p))
+              (deriver  (read-store-path p))
+              (refs     (read-store-path-list p))
+              (dl-size  (read-long-long p))
+              (nar-size (read-long-long p)))
+          (loop (- len 1)
+                (cons (substitutable path deriver refs dl-size nar-size)
+                      result))))))
+
+;; Information about a store path.
+(define-record-type <path-info>
+  (make-path-info deriver hash references registration-time nar-size)
+  path-info?
+  (deriver path-info-deriver)                     ;string | #f
+  (hash path-info-hash)
+  (references path-info-references)
+  (registration-time path-info-registration-time)
+  (nar-size path-info-nar-size))
+
+(define (read-path-info p)
+  (let ((deriver  (match (read-store-path p)
+                    ("" #f)
+                    (x  x)))
+        (hash     (base16-string->bytevector (read-string p)))
+        (refs     (read-store-path-list p))
+        (registration-time (read-int p))
+        (nar-size (read-long-long p)))
+    (make-path-info deriver hash refs registration-time nar-size)))
+
+(define-syntax define-serializable-types
+  (syntax-rules ()
+    "Define READ-ANY and WRITE-ANY as macros that dispatch serialization and
+deserialization of known data types.  These two macros can then be used like so:
+
+  (READ-ANY integer PORT)
+
+and:
+
+  (WRITE-ANY store-path VALUE PORT)
+
+The former returns the value it read; the latter returns the unspecified
+value."
+    ((_ read-any write-any (type read write) ...)
+     (begin
+       ;; Define syntactic keywords.
+       (define-syntax type
+         (lambda (s)
+           #`(syntax-error "invalid use of serializable type name" #,s)))
+       ...
+       (export type ...)
+
+       (define-syntax write-any
+         (syntax-rules (type ...)
+           "Write the following TYPE value to the given port."
+           ((_ type arg port)
+            (write arg port))
+           ...))
+       (define-syntax read-any
+         (syntax-rules (type ...)
+           "Read from the given port a value of TYPE."
+           ((_ type port)
+            (read port))
+           ...))))))
+
+(define no-op (const #t))
+
+;; Serializable types known to the client/daemon protocol.
+(define-serializable-types read-value write-value
+  (integer         read-int write-int)
+  (long-long       read-long-long write-long-long)
+  (boolean         read-boolean write-boolean)
+  (bytevector      read-byte-string write-bytevector)
+  (utf8-string     read-string write-string)   ;avoid name clash with 'string'
+  (string-list     read-string-list write-string-list)
+  (string-pairs    read-string-pairs write-string-pairs)
+  (store-path      read-store-path write-store-path)
+  (store-path-list read-store-path-list write-store-path-list)
+  (base16          read-base16 write-base16)
+  (path-info       read-path-info write-path-info/not-implemented)
+  (substitutable-path-list read-substitutable-path-list
+                           write-substitutable-path-list/not-implemented)
+
+  ;; When reading a file, just return the input port and let the caller (a
+  ;; server) call 'restore-file' or whatever is relevant for the operation.
+  (file            identity write-file)
+
+  ;; User-provided as used in the 'export-path' and 'import-paths' remote
+  ;; procedures.
+  (stream          no-op no-op))
+
 
 (define-condition-type &nar-read-error &nar-error
   nar-read-error?

guix/substitutes.scm

@@ -30,15 +30,19 @@
   #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix cache)
-  #:use-module ((guix build utils) #:select (mkdir-p dump-port))
+  #:use-module ((guix build utils)
+                #:select (mkdir-p dump-port delete-file-recursively))
   #:use-module ((guix build download)
                 #:select ((open-connection-for-uri
                            . guix:open-connection-for-uri)
-                          resolve-uri-reference))
-  #:autoload   (gnutls) (error->string
-                         error/premature-termination
-                         error/pull-error
-                         error/push-error)
+                          resolve-uri-reference
+                          nar-uri-abbreviation))
+  #:use-module ((guix serialization) #:select (restore-file dump-file))
+  #:autoload   (gnutls) (error->string error/premature-termination
+                                       error/invalid-session error/again
+                                       error/interrupted
+                                       error/push-error error/pull-error)
+  #:autoload   (guix store deduplication) (dump-file/deduplicate)
   #:use-module (guix progress)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
@@ -49,6 +53,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-71)
   #:use-module (web uri)
   #:use-module (web request)
   #:use-module (web response)
@@ -58,7 +64,10 @@
             call-with-connection-error-handling
 
             lookup-narinfos
-            lookup-narinfos/diverse))
+            lookup-narinfos/diverse
+
+            http-response-error?
+            download-nar))
 
 (define %narinfo-ttl
   ;; Number of seconds during which cached narinfo lookups are considered
@@ -399,4 +408,209 @@ AUTHORIZED? narinfo."
          (()                                      ;that's it
           (filter-map (select-hit result) hits)))))))
 
+(define %random-state
+  (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
+
+(define-syntax-rule (with-timeout duration handler body ...)
+  "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
+again.  If DURATION is #f, run BODY with no timeout."
+  (let ((thunk (lambda () body ...)))
+    (if duration
+        (begin
+          (sigaction SIGALRM
+            (lambda (signum)
+              (sigaction SIGALRM SIG_DFL)
+              handler))
+          (alarm duration)
+          (call-with-values
+              (lambda ()
+                (let try ()
+                  (catch 'system-error
+                    thunk
+                    (lambda args
+                      ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
+                      ;; because of the bug at
+                      ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
+                      ;; When that happens, try again.  Note: SA_RESTART cannot be
+                      ;; used because of <http://bugs.gnu.org/14640>.
+                      (if (= EINTR (system-error-errno args))
+                          (begin
+                            ;; Wait a little to avoid bursts.
+                            (usleep (random 3000000 %random-state))
+                            (try))
+                          (apply throw args))))))
+            (lambda result
+              (alarm 0)
+              (sigaction SIGALRM SIG_DFL)
+              (apply values result))))
+        (thunk))))
+
+(define-syntax-rule (catch-system-error exp)
+  (catch 'system-error
+    (lambda () exp)
+    (const #f)))
+
+(define http-response-error?
+  (let ((kind-and-args-exception?
+         (exception-predicate &exception-with-kind-and-args)))
+    (lambda (exception)
+      "Return true if EXCEPTION denotes an error with the http response"
+      (->bool
+       (memq (exception-kind exception)
+             '(bad-response bad-header bad-header-component))))))
+
+(define %fetch-timeout
+  ;; Number of seconds after which networking is considered "slow".
+  5)
+
+(define* (download-nar narinfo destination
+                       #:key deduplicate? print-build-trace?
+                       (fetch-timeout %fetch-timeout)
+                       fast-decompression?
+                       (open-connection-for-uri guix:open-connection-for-uri)
+                       (keep-alive? #f))
+  "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.  Use
+OPEN-CONNECTION-FOR-URI to open connections."
+  (define destination-in-store?
+    (string-prefix? (string-append (%store-prefix) "/")
+                    destination))
+
+  (define (dump-file/deduplicate* . args)
+    ;; Make sure deduplication looks at the right store (necessary in test
+    ;; environments).
+    (apply dump-file/deduplicate
+           (append args (list #:store (%store-prefix)))))
+
+  (define (fetch uri)
+    (case (uri-scheme uri)
+      ((file)
+       (let ((port (open-file (uri-path uri) "r0b")))
+         (values port
+                 (stat:size (stat port))
+                 #t)))
+      ((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~%")))
+         (let loop ((port  (open-connection-for-uri uri))
+                    (attempt 0))
+           (guard (c ((or (network-error? c)
+                          (http-response-error? c))
+                      (close-port port)
+
+                      ;; Perform a single retry in the case of an error,
+                      ;; mostly to mimic the behaviour of
+                      ;; with-cached-connection
+                      (if (= attempt 0)
+                          (loop (open-connection-for-uri uri) 1)
+                          (raise c))))
+             (let ((port
+                    response
+                    (http-fetch uri #:text? #f
+                                #:port port
+                                #:keep-alive? keep-alive?
+                                #:buffered? #f)))
+               (values port
+                       (response-content-length response)
+                       (or
+                        (memq 'close
+                              (response-connection response))
+                        (not keep-alive?))))))))
+      (else
+       (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)
+                       (or (http-get-error? c)
+                           (network-error? c)))
+                  (warning (G_ "download from '~a' failed, trying next URL~%")
+                           (uri->string uri))
+                  (try-fetch rest)))
+         (let ((port download-size close? (fetch uri)))
+           (unless print-build-trace?
+             (format (current-error-port)
+                     (G_ "Downloading ~a...~%") (uri->string uri)))
+           (values port uri compression download-size close?))))
+      (()
+       (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.
+  (catch-system-error (delete-file-recursively destination))
+
+  (let ((choices (narinfo-preferred-uris narinfo
+                                         #:fast-decompression?
+                                         fast-decompression?)))
+    ;; 'guix publish' without '--cache' doesn't specify a Content-Length, so
+    ;; DOWNLOAD-SIZE is #f in this case.
+    (let* ((raw uri compression download-size close? (try-fetch choices))
+           (progress
+            (let* ((dl-size  (or download-size
+                                 (and (equal? compression "none")
+                                      (narinfo-size narinfo))))
+                   (reporter (if print-build-trace?
+                                 (progress-reporter/trace
+                                  destination
+                                  (uri->string uri) dl-size
+                                  (current-error-port))
+                                 (progress-reporter/file
+                                  (uri->string uri) dl-size
+                                  (current-error-port)
+                                  #:abbreviation nar-uri-abbreviation))))
+              ;; Keep RAW open upon completion so we can later reuse
+              ;; the underlying connection.  Pass the download size so
+              ;; that this procedure won't block reading from RAW.
+              (progress-report-port reporter raw
+                                    #:close? #f
+                                    #:download-size dl-size)))
+           (input pids
+                  ;; NOTE: This 'progress' port of current process will be
+                  ;; closed here, while the child process doing the
+                  ;; reporting will close it upon exit.
+                  (decompressed-port (string->symbol compression)
+                                     progress))
+
+           ;; Compute the actual nar hash as we read it.
+           (algorithm expected (narinfo-hash-algorithm+value narinfo))
+           (hashed get-hash (open-hash-input-port algorithm input)))
+
+      ;; Unpack the Nar at INPUT into DESTINATION.
+      (restore-file hashed destination
+                    #:dump-file (if (and destination-in-store?
+                                         deduplicate?)
+                                    dump-file/deduplicate*
+                                    dump-file))
+      (close-port hashed)
+      (close-port input)
+
+      ;; Wait for the reporter to finish.
+      (every (compose zero? cdr waitpid) pids)
+
+      (when close?
+        (close-port raw))
+
+      (values expected
+              (get-hash)))))
+
+;;; Local Variables:
+;;; eval: (put 'with-timeout 'scheme-indent-function 1)
+;;; End:
+
 ;;; substitutes.scm ends here

tests/substitute.scm

@@ -618,16 +618,30 @@ System: mips64el-linux\n")))
   (with-narinfo* (string-append %narinfo "Signature: " (signature-field %narinfo))
       %main-substitute-directory
 
+    (define (compress input output compression)
+      (call-with-output-file output
+        (lambda (port)
+          (call-with-compressed-output-port compression port
+            (lambda (port)
+              (call-with-input-file input
+                (lambda (input)
+                  (dump-port input port))))))))
+
+    ;; This test is dependent on which nar the substitute script picks to
+    ;; request first
     (with-http-server `((200 ,(string-append %narinfo "Signature: "
                                              (signature-field %narinfo)
                                              "\n"
                                              "URL: example.nar.lz\n"
                                              "Compression: lzip\n"))
                         (404 "Sorry, nar.lz is missing!")
-                        (200 ,(call-with-input-file
-                                  (string-append %main-substitute-directory
-                                                 "/example.nar")
-                                get-bytevector-all)))
+                        (200 ,(let ((nar (string-append
+                                          %main-substitute-directory
+                                          "/example.nar")))
+                                (compress nar (string-append nar ".lz") 'lzip)
+                                (call-with-input-file
+                                    (string-append nar ".lz")
+                                  get-bytevector-all))))
       (dynamic-wind
         (const #t)
         (lambda ()