ci: Add missing include.

* gnu/ci.scm: Add missing include.

.dir-locals.el

@@ -11,23 +11,34 @@
       . "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>")
 
      ;; Emacs-Guix
-     (eval . (setq guix-directory
-                   (locate-dominating-file default-directory ".dir-locals.el")))
+     (eval . (setq-local guix-directory
+                         (locate-dominating-file default-directory
+                                                 ".dir-locals.el")))
 
      ;; Geiser
      ;; This allows automatically setting the `geiser-guile-load-path'
      ;; variable when using various Guix checkouts (e.g., via git worktrees).
-     (eval . (let* ((root-dir (expand-file-name
-                               (locate-dominating-file
-                                default-directory ".dir-locals.el")))
-                    ;; Workaround for bug https://issues.guix.gnu.org/43818.
-                    (root-dir* (directory-file-name root-dir)))
-               (unless (boundp 'geiser-guile-load-path)
-                 (defvar geiser-guile-load-path '()))
-               (make-local-variable 'geiser-guile-load-path)
-               (require 'cl-lib)
-               (cl-pushnew root-dir* geiser-guile-load-path
-                           :test #'string-equal)))))
+     (eval . (let ((root-dir-unexpanded (locate-dominating-file
+                                         default-directory ".dir-locals.el")))
+               ;; While Guix should in theory always have a .dir-locals.el
+               ;; (we are reading this file, after all) there seems to be a
+               ;; strange problem where this code "escapes" to some other buffers,
+               ;; at least vc-mode.  See:
+               ;;   https://lists.gnu.org/archive/html/guix-devel/2020-11/msg00296.html
+               ;; Upstream report: <https://bugs.gnu.org/44698>
+               ;; Hence the following "when", which might otherwise be unnecessary;
+               ;; it prevents causing an error when root-dir-unexpanded is nil.
+               (when root-dir-unexpanded
+                 (let* ((root-dir (expand-file-name root-dir-unexpanded))
+                        ;; Workaround for bug https://issues.guix.gnu.org/43818.
+                        (root-dir* (directory-file-name root-dir)))
+
+                   (unless (boundp 'geiser-guile-load-path)
+                     (defvar geiser-guile-load-path '()))
+                   (make-local-variable 'geiser-guile-load-path)
+                   (require 'cl-lib)
+                   (cl-pushnew root-dir* geiser-guile-load-path
+                               :test #'string-equal)))))))
 
  (c-mode          . ((c-file-style . "gnu")))
  (scheme-mode

Makefile.am

@@ -562,7 +562,7 @@ dist_zshcompletion_DATA = etc/completion/zsh/_guix
 dist_fishcompletion_DATA = etc/completion/fish/guix.fish
 
 # SELinux policy
-nodist_selinux_policy_DATA = etc/guix-daemon.cil.in
+nodist_selinux_policy_DATA = etc/guix-daemon.cil
 
 EXTRA_DIST +=						\
   HACKING						\
@@ -570,6 +570,7 @@ EXTRA_DIST +=						\
   TODO							\
   CODE-OF-CONDUCT					\
   .dir-locals.el					\
+  .guix-authorizations					\
   .guix-channel						\
   scripts/guix.in					\
   etc/guix-install.sh					\
@@ -730,8 +731,8 @@ distcheck-hook: assert-binaries-available assert-final-inputs-self-contained
 
 EXTRA_DIST += $(top_srcdir)/.version
 BUILT_SOURCES += $(top_srcdir)/.version
-$(top_srcdir)/.version:
-	echo $(VERSION) > "$@-t" && mv "$@-t" "$@"
+$(top_srcdir)/.version: config.status
+	$(AM_V_GEN)echo $(VERSION) > "$@-t" && mv "$@-t" "$@"
 
 gen-tarball-version:
 	echo $(VERSION) > "$(distdir)/.tarball-version"

NEWS

@@ -69,8 +69,19 @@ guix-build-coordinator-agent, guix-build-coordinator-queue-builds, hostapd,
 hurd-console, hurd-getty, hurd-vm, lxqt, rshiny, secret-service,
 simulated-wifi, udev-rules, unattended-upgrade, webssh, zram
 
-*** XXX new packages
-*** XXX package updates
+*** 1999 new packages
+*** 3652 package updates
+
+Noteworthy updates:
+bash 5.0.16, binutils 2.34, cups 2.3.3, emacs 27.1, enlightenment 0.24.2,
+gcc-toolchain 10.2.0, gdb 10.1, ghc 8.8.3, gimp 2.10.22, glibc 2.31,
+gnome 3.34.2, gnupg 2.2.23, go 1.14.10, guile 3.0.4,
+icecat 78.4.0-guix0-preview1, inkscape 1.0.1, julia 1.5.2,
+libreoffice 6.4.6.2, linux-libre 5.9.3, mate 1.24.1, ocaml 4.09.0,
+openjdk 14.0, perl 5.30.2, python2 2.7.17, python 3.8.2, racket 7.8,
+rust 1.46.0, r 4.0.3, sbcl 2.0.10, shepherd 0.8.1, xfce 4.14.2,
+xorg-server 1.20.8
+
 
 ** Programming interfaces
 *** New ‘maven-build-system’, for packages built with Maven
@@ -144,7 +155,15 @@ simulated-wifi, udev-rules, unattended-upgrade, webssh, zram
     (<https://bugs.gnu.org/43744>)
 
 ** Native language support
-*** TODO populate
+*** Updated translations of the manual
+
+The manual is fully translated into French, German, and Spanish, and has
+preliminary translations into Chinese and Russian.
+
+*** Updated translations of messages
+
+This version of Guix is fully translated in French, German, and Spanish, and
+partially translated in 11 other languages.
 
 * Changes in 1.1.0 (since 1.0.1)
 ** Package management

doc/build.scm

@@ -182,32 +182,6 @@ as well as images, OS examples, and translations."
     "-c" "EXTRA_HEAD=<meta name=\"viewport\" \
 content=\"width=device-width, initial-scale=1\" />"))
 
-(define guile-lib/htmlprag-fixed
-  ;; Guile-Lib with a hotfix for (htmlprag).
-  (package
-    (inherit guile-lib)
-    (arguments
-     (substitute-keyword-arguments (package-arguments guile-lib)
-       ((#:phases phases '%standard-phases)
-        `(modify-phases ,phases
-           (add-before 'build 'fix-htmlprag
-             (lambda _
-               ;; When parsing
-               ;; "<body><blockquote><p>foo</p>\n</blockquote></body>",
-               ;; 'html->shtml' would mistakenly close 'blockquote' right
-               ;; before <p>.  This patch removes 'p' from the
-               ;; 'parent-constraints' alist to fix that.
-               (substitute* "src/htmlprag.scm"
-                 (("^[[:blank:]]*\\(p[[:blank:]]+\\. \\(body td th\\)\\).*")
-                  ""))
-               #t))
-           (add-before 'check 'skip-known-failure
-             (lambda _
-               ;; XXX: The above change causes one test failure among
-               ;; the htmlprag tests.
-               (setenv "XFAIL_TESTS" "htmlprag.scm")
-               #t))))))))
-
 (define (normalize-language-code language)        ;XXX: deduplicate
   ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
   (string-map (match-lambda
@@ -224,7 +198,7 @@ key is an identifier and the associated value is the URL reference pointing to
 that identifier.  The URL is constructed by concatenating BASE-URL to the
 actual file name."
   (define build
-    (with-extensions (list guile-lib/htmlprag-fixed)
+    (with-extensions (list guile-lib)
       (with-imported-modules '((guix build utils))
         #~(begin
             (use-modules (guix build utils)
@@ -236,6 +210,8 @@ actual file name."
                          (ice-9 threads)
                          (ice-9 pretty-print))
 
+            (%strict-tokenizer? #t)
+
             (define file-url
               (let ((prefix (string-append #$manual "/")))
                 (lambda (file)
@@ -380,7 +356,7 @@ actual file name."
 to (1) add them a link to SYNTAX-CSS-URL, and (2) highlight the syntax of all
 its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
   (define build
-    (with-extensions (list guile-lib/htmlprag-fixed guile-syntax-highlight)
+    (with-extensions (list guile-lib guile-syntax-highlight)
       (with-imported-modules '((guix build utils))
         #~(begin
             (use-modules (htmlprag)
@@ -394,6 +370,8 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                          (ice-9 threads)
                          (ice-9 vlist))
 
+            (%strict-tokenizer? #t)
+
             (define (pair-open/close lst)
               ;; Pair 'open' and 'close' tags produced by 'highlights' and
               ;; produce nested 'paren' tags instead.

doc/guix.texi

@@ -2751,7 +2751,7 @@ the command prints and, similar to what we saw above, paste these two
 lines in your terminal and @file{.bash_profile}:
 
 @example
-GUIX_PROFILE="$HOME/.config/guix/current/etc/profile"
+GUIX_PROFILE="$HOME/.config/guix/current"
 . "$GUIX_PROFILE/etc/profile"
 @end example
 

etc/guix-daemon.cil.in

@@ -1,6 +1,8 @@
 ; -*- lisp -*-
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2020 Daniel Brooks <db48x@db48x.net>
+;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +23,18 @@
 ;; Intermediate Language (CIL).  It refers to types that must be defined in
 ;; the system's base policy.
 
+;; If you, like me, need advice about fixing an SELinux policy, I recommend
+;; reading https://danwalsh.livejournal.com/55324.html
+
+;; In particular, you can run semanage permissive -a guix_daemon.guix_daemon_t
+;; to allow guix-daemon to do whatever it wants. SELinux will still check its
+;; permissions, and when it doesn't have permission it will still send an
+;; audit message to your system logs. This lets you know what permissions it
+;; ought to have. Use ausearch --raw to find the permissions violations, then
+;; pipe that to audit2allow to generate an updated policy. You'll still need
+;; to translate that policy into CIL in order to update this file, but that's
+;; fairly straight-forward. Annoying, but easy.
+
 (block guix_daemon
   ;; Require existing types
   (typeattributeset cil_gen_require init_t)
@@ -34,14 +48,19 @@
   (roletype object_r guix_daemon_t)
   (type guix_daemon_conf_t)
   (roletype object_r guix_daemon_conf_t)
+  (typeattributeset file_type guix_daemon_conf_t)
   (type guix_daemon_exec_t)
   (roletype object_r guix_daemon_exec_t)
+  (typeattributeset file_type guix_daemon_exec_t)
   (type guix_daemon_socket_t)
   (roletype object_r guix_daemon_socket_t)
+  (typeattributeset file_type guix_daemon_socket_t)
   (type guix_store_content_t)
   (roletype object_r guix_store_content_t)
+  (typeattributeset file_type guix_store_content_t)
   (type guix_profiles_t)
   (roletype object_r guix_profiles_t)
+  (typeattributeset file_type guix_profiles_t)
 
   ;; These types are domains, thereby allowing process rules
   (typeattributeset domain (guix_daemon_t guix_daemon_exec_t))
@@ -55,6 +74,30 @@
   (typetransition guix_store_content_t guix_daemon_exec_t
                   process guix_daemon_t)
 
+  (roletype system_r guix_daemon_t)
+
+  ;; allow init_t to read and execute guix files
+  (allow init_t
+         guix_profiles_t
+         (lnk_file (read)))
+  (allow init_t
+         guix_daemon_exec_t
+         (file (execute)))
+  (allow init_t
+         guix_daemon_t
+         (process (transition)))
+  (allow init_t
+         guix_store_content_t
+         (lnk_file (read)))
+  (allow init_t
+         guix_store_content_t
+         (file (open read execute)))
+
+  ;; guix-daemon needs to know the names of users
+  (allow guix_daemon_t
+         passwd_file_t
+         (file (getattr open read)))
+
   ;; Permit communication with NSCD
   (allow guix_daemon_t
          nscd_var_run_t
@@ -71,25 +114,44 @@
   (allow guix_daemon_t
          nscd_t
          (unix_stream_socket (connectto)))
+  (allow guix_daemon_t nscd_t
+         (nscd (getgrp gethost getpwd getserv shmemgrp shmemhost shmempwd shmemserv)))
+
+  ;; permit downloading packages via HTTP(s)
+  (allow guix_daemon_t http_port_t
+         (tcp_socket (name_connect)))
+  (allow guix_daemon_t ftp_port_t
+         (tcp_socket (name_connect)))
+  (allow guix_daemon_t ephemeral_port_t
+         (tcp_socket (name_connect)))
 
   ;; Permit logging and temp file access
   (allow guix_daemon_t
          tmp_t
-         (lnk_file (setattr unlink)))
+         (lnk_file (create rename setattr unlink)))
   (allow guix_daemon_t
          tmp_t
-         (dir (create
-               rmdir
+         (file (link rename create execute execute_no_trans write unlink setattr map relabelto)))
+  (allow guix_daemon_t
+         tmp_t
+         (fifo_file (open read write create getattr ioctl setattr unlink)))
+  (allow guix_daemon_t
+         tmp_t
+         (dir (create rename
+               rmdir relabelto
                add_name remove_name
                open read write
                getattr setattr
                search)))
+  (allow guix_daemon_t
+         tmp_t
+         (sock_file (create getattr setattr unlink write)))
   (allow guix_daemon_t
          var_log_t
          (file (create getattr open write)))
   (allow guix_daemon_t
          var_log_t
-         (dir (getattr write add_name)))
+         (dir (getattr create write add_name)))
   (allow guix_daemon_t
          var_run_t
          (lnk_file (read)))
@@ -100,10 +162,10 @@
   ;; Spawning processes, execute helpers
   (allow guix_daemon_t
          self
-         (process (fork)))
+         (process (fork execmem setrlimit setpgid setsched)))
   (allow guix_daemon_t
          guix_daemon_exec_t
-         (file (execute execute_no_trans read open)))
+         (file (execute execute_no_trans read open entrypoint map)))
 
   ;; TODO: unknown
   (allow guix_daemon_t
@@ -119,38 +181,51 @@
   ;; Build isolation
   (allow guix_daemon_t
          guix_store_content_t
-         (file (mounton)))
+         (file (ioctl mounton)))
   (allow guix_store_content_t
          fs_t
          (filesystem (associate)))
   (allow guix_daemon_t
          guix_store_content_t
-         (dir (mounton)))
+         (dir (read mounton)))
   (allow guix_daemon_t
          guix_daemon_t
          (capability (net_admin
                       fsetid fowner
                       chown setuid setgid
                       dac_override dac_read_search
-                      sys_chroot)))
+                      sys_chroot
+                      sys_admin)))
   (allow guix_daemon_t
          fs_t
          (filesystem (unmount)))
+  (allow guix_daemon_t
+         devpts_t
+         (dir (search)))
   (allow guix_daemon_t
          devpts_t
          (filesystem (mount)))
   (allow guix_daemon_t
          devpts_t
-         (chr_file (setattr getattr)))
+         (chr_file (ioctl open read write setattr getattr)))
   (allow guix_daemon_t
          tmpfs_t
-         (filesystem (mount)))
+         (filesystem (getattr mount)))
   (allow guix_daemon_t
          tmpfs_t
-         (dir (getattr)))
+         (file (create open read unlink write)))
+  (allow guix_daemon_t
+         tmpfs_t
+         (dir (getattr add_name remove_name write)))
   (allow guix_daemon_t
          proc_t
-         (filesystem (mount)))
+         (file (getattr open read)))
+  (allow guix_daemon_t
+         proc_t
+         (dir (read)))
+  (allow guix_daemon_t
+         proc_t
+         (filesystem (associate mount)))
   (allow guix_daemon_t
          null_device_t
          (chr_file (getattr open read write)))
@@ -179,7 +254,7 @@
                search rename
                add_name remove_name
                open write
-               rmdir)))
+               rmdir relabelfrom)))
   (allow guix_daemon_t
          guix_store_content_t
          (file (create
@@ -189,7 +264,7 @@
                 link unlink
                 map
                 rename
-                open read write)))
+                open read write relabelfrom)))
   (allow guix_daemon_t
          guix_store_content_t
          (lnk_file (create
@@ -197,17 +272,23 @@
                     link unlink
                     read
                     rename)))
+  (allow guix_daemon_t
+         guix_store_content_t
+         (fifo_file (create getattr open read unlink write)))
+  (allow guix_daemon_t
+         guix_store_content_t
+         (sock_file (create getattr unlink write)))
 
   ;; Access to configuration files and directories
   (allow guix_daemon_t
          guix_daemon_conf_t
-         (dir (search
+         (dir (search create
                setattr getattr
                add_name remove_name
                open read write)))
   (allow guix_daemon_t
          guix_daemon_conf_t
-         (file (create
+         (file (create rename
                 lock
                 map
                 getattr setattr
@@ -216,11 +297,17 @@
   (allow guix_daemon_t
          guix_daemon_conf_t
          (lnk_file (create getattr rename unlink)))
+  (allow guix_daemon_t net_conf_t
+         (file (getattr open read)))
+  (allow guix_daemon_t net_conf_t
+         (lnk_file (read)))
+  (allow guix_daemon_t NetworkManager_var_run_t
+         (dir (search)))
 
   ;; Access to profiles
   (allow guix_daemon_t
          guix_profiles_t
-         (dir (getattr setattr read open)))
+         (dir (search getattr setattr read write open create add_name)))
   (allow guix_daemon_t
          guix_profiles_t
          (lnk_file (read getattr)))
@@ -233,8 +320,22 @@
   (allow guix_daemon_t
          user_home_t
          (dir (search)))
+  (allow guix_daemon_t
+         cache_home_t
+         (dir (search)))
+
+  ;; self upgrades
+  (allow guix_daemon_t
+         self
+         (dir (add_name write)))
+  (allow guix_daemon_t
+         self
+         (netlink_route_socket (bind create getattr nlmsg_read read write)))
 
   ;; Socket operations
+  (allow guix_daemon_t
+         guix_daemon_socket_t
+         (sock_file (unlink)))
   (allow guix_daemon_t
          init_t
          (fd (use)))
@@ -253,12 +354,53 @@
                               read write
                               connect bind accept
                               getopt setopt)))
+  (allow guix_daemon_t
+         self
+         (tcp_socket (accept listen bind connect create setopt getopt getattr ioctl read write shutdown)))
+  (allow guix_daemon_t
+         unreserved_port_t
+         (tcp_socket (name_bind name_connect accept listen)))
+  (allow guix_daemon_t
+         self
+         (udp_socket (connect getattr bind getopt setopt)))
   (allow guix_daemon_t
          self
          (fifo_file (write read)))
   (allow guix_daemon_t
          self
          (udp_socket (ioctl create)))
+  (allow guix_daemon_t
+         self
+         (unix_stream_socket (connectto)))
+
+  (allow guix_daemon_t
+         node_t
+         (tcp_socket (node_bind)))
+  (allow guix_daemon_t
+         node_t
+         (udp_socket (node_bind)))
+  (allow guix_daemon_t
+         port_t
+         (tcp_socket (name_connect)))
+  (allow guix_daemon_t
+         rtp_media_port_t
+         (udp_socket (name_bind)))
+  (allow guix_daemon_t
+         vnc_port_t
+         (tcp_socket (name_bind)))
+
+  ;; I guess sometimes it needs random numbers
+  (allow guix_daemon_t
+         random_device_t
+         (chr_file (read)))
+
+  ;; guix system vm
+  (allow guix_daemon_t
+         kvm_device_t
+         (chr_file (ioctl open read write)))
+  (allow guix_daemon_t
+         kernel_t
+         (system (ipc_info)))
 
   ;; Label file system
   (filecon "@guix_sysconfdir@/guix(/.*)?"
@@ -277,5 +419,7 @@
            file (system_u object_r guix_daemon_exec_t (low low)))
   (filecon "@storedir@/.+-(guix-.+|profile)/bin/guix-daemon"
            file (system_u object_r guix_daemon_exec_t (low low)))
+  (filecon "@storedir@/[a-z0-9]+-guix-daemon"
+           file (system_u object_r guix_daemon_exec_t (low low)))
   (filecon "@guix_localstatedir@/guix/daemon-socket/socket"
            any (system_u object_r guix_daemon_socket_t (low low))))

etc/guix-install.sh

@@ -6,6 +6,7 @@
 # Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 # Copyright © 2020 Morgan Smith <Morgan.J.Smith@outlook.com>
 # Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+# Copyright © 2020 Daniel Brooks <db48x@db48x.net>
 #
 # This file is part of GNU Guix.
 #
@@ -60,6 +61,7 @@ INF="[ INFO ] "
 
 DEBUG=0
 GNU_URL="https://ftp.gnu.org/gnu/guix/"
+#GNU_URL="https://alpha.gnu.org/gnu/guix/"
 OPENPGP_SIGNING_KEY_ID="3CE464558A84FDC69DB40CFB090B11993D9AEBB5"
 
 # This script needs to know where root's home directory is.  However, we
@@ -228,11 +230,11 @@ guix_get_bin_list()
 
     # Filter only version and architecture
     bin_ver_ls=("$(wget -qO- "$gnu_url" \
-        | sed -n -e 's/.*guix-binary-\([0-9.]*\)\..*.tar.xz.*/\1/p' \
+        | sed -n -e 's/.*guix-binary-\([0-9.]*[a-z0-9]*\)\..*.tar.xz.*/\1/p' \
         | sort -Vu)")
 
     latest_ver="$(echo "$bin_ver_ls" \
-                       | grep -oE "([0-9]{1,2}\.){2}[0-9]{1,2}" \
+                       | grep -oE "([0-9]{1,2}\.){2}[0-9]{1,2}[a-z0-9]*" \
                        | tail -n1)"
 
     default_ver="guix-binary-${latest_ver}.${ARCH_OS}"

gnu/ci.scm

@@ -3,6 +3,7 @@
 ;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,7 +21,9 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu ci)
+  #:use-module (guix channels)
   #:use-module (guix config)
+  #:use-module (guix describe)
   #:use-module (guix store)
   #:use-module (guix grafts)
   #:use-module (guix profiles)
@@ -34,7 +37,8 @@
   #:use-module (guix ui)
   #:use-module ((guix licenses)
                 #:select (gpl3+ license? license-name))
-  #:use-module ((guix utils) #:select (%current-system))
+  #:use-module ((guix utils) #:select (%current-system
+                                       location-file))
   #:use-module ((guix scripts system) #:select (read-operating-system))
   #:use-module ((guix scripts pack)
                 #:select (lookup-compressor self-contained-tarball))
@@ -61,67 +65,123 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
-  #:export (%cross-targets
+  #:export (derivation->job
+            image->job
+
+            %core-packages
+            %cross-targets
             channel-source->package
-            hydra-jobs))
+
+            arguments->systems
+            cuirass-jobs))
 
 ;;; Commentary:
 ;;;
-;;; This file defines build jobs for the Hydra and Cuirass continuation
-;;; integration tools.
+;;; This file defines build jobs for Cuirass.
 ;;;
 ;;; Code:
 
-(define* (package->alist store package system
-                         #:optional (package-derivation package-derivation))
-  "Convert PACKAGE to an alist suitable for Hydra."
-  (parameterize ((%graft? #f))
-    (let ((drv (package-derivation store package system
-                                   #:graft? #f)))
-      `((derivation . ,(derivation-file-name drv))
-        (log . ,(log-file store (derivation-file-name drv)))
-        (outputs . ,(filter-map (lambda (res)
-                                  (match res
-                                    ((name . path)
-                                     `(,name . ,path))))
-                                (derivation->output-paths drv)))
-        (nix-name . ,(derivation-name drv))
-        (system . ,(derivation-system drv))
-        (description . ,(package-synopsis package))
-        (long-description . ,(package-description package))
+;; Backport from (guix channels) module.
+(define* (sexp->channel sexp #:optional (name 'channel))
+  "Read SEXP, a provenance sexp as created by 'channel-instance->sexp'; use
+NAME as the channel name if SEXP does not specify it.  Return #f if the sexp
+does not have the expected structure."
+  (match sexp
+    (('repository ('version 0)
+                  ('url url)
+                  ('branch branch)
+                  ('commit commit)
+                  rest ...)
+     ;; Historically channel sexps did not include the channel name.  It's OK
+     ;; for channels created by 'channel-instances->manifest' because the
+     ;; entry name is the channel name, but it was missing for entries created
+     ;; by 'manifest-entry-with-provenance'.
+     (channel (name (match (assq 'name rest)
+                      (#f name)
+                      (('name name) name)))
+              (url url)
+              (branch branch)
+              (commit commit)
+              (introduction
+               (match (assq 'introduction rest)
+                 (#f #f)
+                 (('introduction intro)
+                  (sexp->channel-introduction intro))))))
 
-        ;; XXX: Hydra ignores licenses that are not a <license> structure or a
-        ;; list thereof.
-        (license . ,(let loop ((license (package-license package)))
-                      (match license
-                        ((? license?)
-                         (license-name license))
-                        ((lst ...)
-                         (map loop license)))))
+    (_ #f)))
 
-        (home-page . ,(package-home-page package))
-        (maintainers . ("bug-guix@gnu.org"))
-        (max-silent-time . ,(or (assoc-ref (package-properties package)
-                                           'max-silent-time)
-                                3600))              ;1 hour by default
-        (timeout . ,(or (assoc-ref (package-properties package) 'timeout)
-                        72000))))))                  ;20 hours by default
+;; Backport from (guix describe) module.
+(define (package-channels package)
+  "Return the list of channels providing PACKAGE or an empty list if it could
+not be determined."
+  (match (and=> (package-location package) location-file)
+    (#f '())
+    (file
+     (let ((file (if (string-prefix? "/" file)
+                     file
+                     (search-path %load-path file))))
+       (if (and file
+                (string-prefix? (%store-prefix) file))
+           (filter-map
+            (lambda (entry)
+              (let ((item (manifest-entry-item entry)))
+                (and (or (string-prefix? item file)
+                         (string=? "guix" (manifest-entry-name entry)))
+                     (manifest-entry-channel entry))))
+            (current-profile-entries))
+           '())))))
 
-(define (package-job store job-name package system)
+(define* (derivation->job name drv
+                          #:key
+                          (max-silent-time 3600)
+                          (timeout 3600))
+  "Return a Cuirass job called NAME and describing DRV.
+
+MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
+building the derivation."
+  `((#:job-name . ,name)
+    (#:derivation . ,(derivation-file-name drv))
+    (#:inputs . ,(map (compose derivation-file-name
+                               derivation-input-derivation)
+                      (derivation-inputs drv)))
+    (#:outputs . ,(filter-map
+                   (lambda (res)
+                     (match res
+                       ((name . path)
+                        `(,name . ,path))))
+                   (derivation->output-paths drv)))
+    (#:nix-name . ,(derivation-name drv))
+    (#:system . ,(derivation-system drv))
+    (#:max-silent-time . ,max-silent-time)
+    (#:timeout . ,timeout)))
+
+(define* (package-job store job-name package system
+                      #:key cross? target)
   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
-  (let ((job-name (symbol-append job-name (string->symbol ".")
-                                 (string->symbol system))))
-    `(,job-name . ,(cut package->alist store package system))))
+  (let ((job-name (string-append job-name "." system)))
+    (parameterize ((%graft? #f))
+      (let* ((drv (if cross?
+                      (package-cross-derivation store package target system
+                                                #:graft? #f)
+                      (package-derivation store package system
+                                          #:graft? #f)))
+             (max-silent-time (or (assoc-ref (package-properties package)
+                                             'max-silent-time)
+                                  3600))
+             (timeout (or (assoc-ref (package-properties package)
+                                     'timeout)
+                          72000)))
+        (derivation->job job-name drv
+                         #:max-silent-time max-silent-time
+                         #:timeout timeout)))))
 
 (define (package-cross-job store job-name package target system)
   "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
 SYSTEM."
-  `(,(symbol-append (string->symbol target) (string->symbol ".") job-name
-                    (string->symbol ".") (string->symbol system)) .
-    ,(cute package->alist store package system
-           (lambda* (store package system #:key graft?)
-             (package-cross-derivation store package target system
-                                       #:graft? graft?)))))
+  (let ((name (string-append target "." job-name "." system)))
+    (package-job store name package system
+                 #:cross? #t
+                 #:target target)))
 
 (define %core-packages
   ;; Note: Don't put the '-final' package variants because (1) that's
@@ -149,6 +209,7 @@ SYSTEM."
     "arm-linux-gnueabihf"
     "aarch64-linux-gnu"
     "powerpc-linux-gnu"
+    "powerpc64le-linux-gnu"
     "riscv64-linux-gnu"
     "i586-pc-gnu"                                 ;aka. GNU/Hurd
     "i686-w64-mingw32"
@@ -197,6 +258,22 @@ SYSTEM."
               (remove (either from-32-to-64? same? pointless?)
                       %cross-targets)))
 
+(define* (guix-jobs store systems #:key source commit)
+  "Return a list of jobs for Guix itself."
+  (define build
+    (primitive-load (string-append source "/build-aux/build-self.scm")))
+
+  (map
+   (lambda (system)
+     (let ((name (string->symbol
+                  (string-append "guix." system)))
+           (drv (run-with-store store
+                  (build source #:version commit #:system system
+                         #:pull-version 1
+                         #:guile-version "2.2"))))
+       (derivation->job name drv)))
+   systems))
+
 ;; Architectures that are able to build or cross-build Guix System images.
 ;; This does not mean that other architectures are not supported, only that
 ;; they are often not fast enough to support Guix System images building.
@@ -207,63 +284,51 @@ SYSTEM."
   (list hurd-barebones-qcow2-image
         pine64-barebones-raw-image))
 
+(define (hours hours)
+  (* 3600 hours))
+
+(define* (image->job store image
+                     #:key name system)
+  "Return the job for IMAGE on SYSTEM.  If NAME is passed, use it as job name,
+otherwise use the IMAGE name."
+  (let* ((image-name (or name
+                         (symbol->string (image-name image))))
+         (name (string-append image-name "." system))
+         (drv (run-with-store store
+                (mbegin %store-monad
+                  (set-guile-for-build (default-guile))
+                  (lower-object (system-image image))))))
+    (parameterize ((%graft? #f))
+      (derivation->job name drv))))
+
 (define (image-jobs store system)
   "Return a list of jobs that build images for SYSTEM."
-  (define (->alist drv)
-    `((derivation . ,(derivation-file-name drv))
-      (log . ,(log-file store (derivation-file-name drv)))
-      (outputs . ,(filter-map (lambda (res)
-                                (match res
-                                  ((name . path)
-                                   `(,name . ,path))))
-                              (derivation->output-paths drv)))
-      (nix-name . ,(derivation-name drv))
-      (system . ,(derivation-system drv))
-      (description . "Stand-alone image of the GNU system")
-      (long-description . "This is a demo stand-alone image of the GNU
-system.")
-      (license . ,(license-name gpl3+))
-      (max-silent-time . 600)
-      (timeout . 3600)
-      (home-page . ,%guix-home-page-url)
-      (maintainers . ("bug-guix@gnu.org"))))
-
-  (define (->job name drv)
-    (let ((name (symbol-append name (string->symbol ".")
-                               (string->symbol system))))
-      `(,name . ,(lambda ()
-                   (parameterize ((%graft? #f))
-                     (->alist drv))))))
-
-  (define (build-image image)
-    (run-with-store store
-      (mbegin %store-monad
-        (set-guile-for-build (default-guile))
-        (lower-object (system-image image)))))
-
   (define MiB
     (expt 2 20))
 
   (if (member system %guix-system-supported-systems)
-      `(,(->job 'usb-image
-                (build-image
-                 (image
-                  (inherit efi-disk-image)
-                  (operating-system installation-os))))
-        ,(->job 'iso9660-image
-                (build-image
-                 (image
-                  (inherit (image-with-label
-                             iso9660-image
-                             (string-append "GUIX_" system "_"
-                                            (if (> (string-length %guix-version) 7)
-                                                (substring %guix-version 0 7)
-                                                %guix-version))))
-                  (operating-system installation-os))))
+      `(,(image->job store
+                     (image
+                      (inherit efi-disk-image)
+                      (operating-system installation-os))
+                     #:name "usb-image"
+                     #:system system)
+        ,(image->job
+          store
+          (image
+           (inherit (image-with-label
+                     iso9660-image
+                     (string-append "GUIX_" system "_"
+                                    (if (> (string-length %guix-version) 7)
+                                        (substring %guix-version 0 7)
+                                        %guix-version))))
+           (operating-system installation-os))
+          #:name "iso9660-image"
+          #:system system)
         ;; Only cross-compile Guix System images from x86_64-linux for now.
         ,@(if (string=? system "x86_64-linux")
-              (map (lambda (image)
-                     (->job (image-name image) (build-image image)))
+              (map (cut image->job store <>
+                        #:system system)
                    %guix-system-images)
               '()))
       '()))
@@ -311,39 +376,17 @@ system.")
 (define* (system-test-jobs store system
                            #:key source commit)
   "Return a list of jobs for the system tests."
-  (define (test->thunk test)
-    (lambda ()
-      (define drv
-        (run-with-store store
-          (mbegin %store-monad
-            (set-current-system system)
-            (set-grafting #f)
-            (set-guile-for-build (default-guile))
-            (system-test-value test))))
-
-      `((derivation . ,(derivation-file-name drv))
-        (log . ,(log-file store (derivation-file-name drv)))
-        (outputs . ,(filter-map (lambda (res)
-                                  (match res
-                                    ((name . path)
-                                     `(,name . ,path))))
-                                (derivation->output-paths drv)))
-        (nix-name . ,(derivation-name drv))
-        (system . ,(derivation-system drv))
-        (description . ,(format #f "Guix '~a' system test"
-                                (system-test-name test)))
-        (long-description . ,(system-test-description test))
-        (license . ,(license-name gpl3+))
-        (max-silent-time . 600)
-        (timeout . 3600)
-        (home-page . ,%guix-home-page-url)
-        (maintainers . ("bug-guix@gnu.org")))))
-
   (define (->job test)
-    (let ((name (string->symbol
-                 (string-append "test." (system-test-name test)
-                                "." system))))
-      (cons name (test->thunk test))))
+    (let ((name (string-append "test." (system-test-name test)
+                               "." system))
+          (drv (run-with-store store
+                 (mbegin %store-monad
+                   (set-current-system system)
+                   (set-grafting #f)
+                   (set-guile-for-build (default-guile))
+                   (system-test-value test)))))
+
+      (derivation->job name drv)))
 
   (if (member system %guix-system-supported-systems)
       ;; Override the value of 'current-guix' used by system tests.  Using a
@@ -356,63 +399,45 @@ system.")
       '()))
 
 (define (tarball-jobs store system)
-  "Return Hydra jobs to build the self-contained Guix binary tarball."
-  (define (->alist drv)
-    `((derivation . ,(derivation-file-name drv))
-      (log . ,(log-file store (derivation-file-name drv)))
-      (outputs . ,(filter-map (lambda (res)
-                                (match res
-                                  ((name . path)
-                                   `(,name . ,path))))
-                              (derivation->output-paths drv)))
-      (nix-name . ,(derivation-name drv))
-      (system . ,(derivation-system drv))
-      (description . "Stand-alone binary Guix tarball")
-      (long-description . "This is a tarball containing binaries of Guix and
-all its dependencies, and ready to be installed on \"foreign\" distributions.")
-      (license . ,(license-name gpl3+))
-      (home-page . ,%guix-home-page-url)
-      (maintainers . ("bug-guix@gnu.org"))))
-
+  "Return jobs to build the self-contained Guix binary tarball."
   (define (->job name drv)
-    (let ((name (symbol-append name (string->symbol ".")
-                               (string->symbol system))))
-      `(,name . ,(lambda ()
-                   (parameterize ((%graft? #f))
-                     (->alist drv))))))
+    (let ((name (string-append name "." system)))
+      (parameterize ((%graft? #f))
+        (derivation->job name drv))))
 
   ;; XXX: Add a job for the stable Guix?
-  (list (->job 'binary-tarball
-               (run-with-store store
-                 (mbegin %store-monad
-                   (set-guile-for-build (default-guile))
-                   (>>= (profile-derivation (packages->manifest (list guix)))
-                        (lambda (profile)
-                          (self-contained-tarball "guix-binary" profile
-                                                  #:localstatedir? #t
-                                                  #:compressor
-                                                  (lookup-compressor "xz")))))
-                 #:system system))))
+  (list
+   (->job "binary-tarball"
+          (run-with-store store
+            (mbegin %store-monad
+              (set-guile-for-build (default-guile))
+              (>>= (profile-derivation (packages->manifest (list guix)))
+                   (lambda (profile)
+                     (self-contained-tarball "guix-binary" profile
+                                             #:profile-name "current-guix"
+                                             #:localstatedir? #t
+                                             #:compressor
+                                             (lookup-compressor "xz")))))
+            #:system system))))
 
 (define job-name
   ;; Return the name of a package's job.
-  (compose string->symbol
-           (cut package-full-name <> "-")))
+  package-name)
 
 (define package->job
   (let ((base-packages
          (delete-duplicates
           (append-map (match-lambda
-                       ((_ package _ ...)
-                        (match (package-transitive-inputs package)
-                          (((_ inputs _ ...) ...)
-                           inputs))))
+                        ((_ package _ ...)
+                         (match (package-transitive-inputs package)
+                           (((_ inputs _ ...) ...)
+                            inputs))))
                       (%final-inputs)))))
     (lambda (store package system)
       "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
 valid."
       (cond ((member package base-packages)
-             (package-job store (symbol-append 'base. (job-name package))
+             (package-job store (string-append "base." (job-name package))
                           package system))
             ((supported-package? package system)
              (let ((drv (package-derivation store package system
@@ -446,14 +471,15 @@ valid."
                           packages)))
                  #:select? (const #t)))           ;include hidden packages
 
-(define (arguments->manifests arguments)
+(define (arguments->manifests arguments channels)
   "Return the list of manifests extracted from ARGUMENTS."
-  (map (match-lambda
-         ((input-name . relative-path)
-          (let* ((checkout (assq-ref arguments (string->symbol input-name)))
-                 (base (assq-ref checkout 'file-name)))
-            (in-vicinity base relative-path))))
-       (assq-ref arguments 'manifests)))
+  (map (lambda (manifest)
+         (any (lambda (checkout)
+                (let ((path (in-vicinity checkout manifest)))
+                  (and (file-exists? path)
+                       path)))
+              (map channel-url channels)))
+       arguments))
 
 (define (manifests->packages store manifests)
   "Return the list of packages found in MANIFESTS."
@@ -469,100 +495,123 @@ valid."
                              load-manifest)
                     manifests))))
 
-(define (find-current-checkout arguments)
-  "Find the first checkout of ARGUMENTS that provided the current file.
-Return #f if no such checkout is found."
-  (let ((current-root
-         (canonicalize-path
-          (string-append (dirname (current-filename)) "/.."))))
-    (find (lambda (argument)
-            (and=> (assq-ref argument 'file-name)
-                   (lambda (name)
-                     (string=? name current-root)))) arguments)))
+(define (arguments->systems arguments)
+  "Return the systems list from ARGUMENTS."
+  (match (assoc-ref arguments 'systems)
+    (#f              %cuirass-supported-systems)
+    ((lst ...)       lst)
+    ((? string? str) (call-with-input-string str read))))
 
 
 ;;;
-;;; Hydra entry point.
+;;; Cuirass entry point.
 ;;;
 
-(define (hydra-jobs store arguments)
-  "Return Hydra jobs."
+(define (cuirass-jobs store arguments)
+  "Register Cuirass jobs."
   (define subset
-    (match (assoc-ref arguments 'subset)
-      ("core" 'core)                              ; only build core packages
-      ("hello" 'hello)                            ; only build hello
-      (((? string?) (? string?) ...) 'list)       ; only build selected list of packages
-      ("manifests" 'manifests)                    ; only build packages in the list of manifests
-      (_ 'all)))                                  ; build everything
+    (assoc-ref arguments 'subset))
 
   (define systems
-    (match (assoc-ref arguments 'systems)
-      (#f              %hydra-supported-systems)
-      ((lst ...)       lst)
-      ((? string? str) (call-with-input-string str read))))
+    (arguments->systems arguments))
 
-  (define checkout
-    (or (find-current-checkout arguments)
-        (assq-ref arguments 'superior-guix-checkout)))
+  (define channels
+    (let ((channels (assq-ref arguments 'channels)))
+      (map sexp->channel channels)))
+
+  (define guix
+    (find guix-channel? channels))
 
   (define commit
-    (assq-ref checkout 'revision))
+    (channel-commit guix))
 
   (define source
-    (assq-ref checkout 'file-name))
+    (channel-url guix))
 
   ;; Turn off grafts.  Grafting is meant to happen on the user's machines.
   (parameterize ((%graft? #f))
     ;; Return one job for each package, except bootstrap packages.
-    (append-map (lambda (system)
-                  (format (current-error-port)
-                          "evaluating for '~a' (heap size: ~a MiB)...~%"
-                          system
-                          (round
-                           (/ (assoc-ref (gc-stats) 'heap-size)
-                              (expt 2. 20))))
-                  (invalidate-derivation-caches!)
-                  (case subset
-                    ((all)
-                     ;; Build everything, including replacements.
-                     (let ((all (all-packages))
-                           (job (lambda (package)
-                                  (package->job store package
-                                                system))))
-                       (append (filter-map job all)
-                               (image-jobs store system)
-                               (system-test-jobs store system
-                                                 #:source source
-                                                 #:commit commit)
-                               (tarball-jobs store system)
-                               (cross-jobs store system))))
-                    ((core)
-                     ;; Build core packages only.
-                     (append (map (lambda (package)
-                                    (package-job store (job-name package)
-                                                 package system))
-                                  %core-packages)
-                             (cross-jobs store system)))
-                    ((hello)
-                     ;; Build hello package only.
-                     (let ((hello (specification->package "hello")))
-                       (list (package-job store (job-name hello) hello system))))
-                    ((list)
-                     ;; Build selected list of packages only.
-                     (let* ((names (assoc-ref arguments 'subset))
-                            (packages (map specification->package names)))
-                       (map (lambda (package)
-                              (package-job store (job-name package)
-                                           package system))
-                            packages)))
-                    ((manifests)
-                     ;; Build packages in the list of manifests.
-                     (let* ((manifests (arguments->manifests arguments))
-                            (packages (manifests->packages store manifests)))
-                       (map (lambda (package)
-                              (package-job store (job-name package)
-                                           package system))
-                            packages)))
-                    (else
-                     (error "unknown subset" subset))))
-                systems)))
+    (append-map
+     (lambda (system)
+       (format (current-error-port)
+               "evaluating for '~a' (heap size: ~a MiB)...~%"
+               system
+               (round
+                (/ (assoc-ref (gc-stats) 'heap-size)
+                   (expt 2. 20))))
+       (invalidate-derivation-caches!)
+       (match subset
+         ('all
+          ;; Build everything, including replacements.
+          (let ((all (all-packages))
+                (job (lambda (package)
+                       (package->job store package system))))
+            (append
+             (filter-map job all)
+             (cross-jobs store system))))
+         ('core
+          ;; Build core packages only.
+          (append
+           (map (lambda (package)
+                  (package-job store (job-name package)
+                               package system))
+                %core-packages)
+           (cross-jobs store system)))
+         ('guix
+          ;; Build Guix modules only.
+          (guix-jobs store systems
+                     #:source source
+                     #:commit commit))
+         ('hello
+          ;; Build hello package only.
+          (let ((hello (specification->package "hello")))
+            (list (package-job store (job-name hello)
+                               hello system))))
+         ('images
+          ;; Build Guix System images only.
+          (image-jobs store system))
+         ('system-tests
+          ;; Build Guix System tests only.
+          (system-test-jobs store system
+                            #:source source
+                            #:commit commit))
+         ('tarball
+          ;; Build Guix tarball only.
+          (tarball-jobs store system))
+         (('custom . modules)
+          ;; Build custom modules jobs only.
+          (append-map
+           (lambda (module)
+             (let ((proc (module-ref
+                          (resolve-interface module)
+                          'cuirass-jobs)))
+               (proc store arguments)))
+           modules))
+         (('channels . channels)
+          ;; Build only the packages from CHANNELS.
+          (let ((all (all-packages)))
+            (filter-map
+             (lambda (package)
+               (any (lambda (channel)
+                      (and (member (channel-name channel) channels)
+                           (package->job store package system)))
+                    (package-channels package)))
+             all)))
+         (('packages . rest)
+          ;; Build selected list of packages only.
+          (let ((packages (map specification->package rest)))
+            (map (lambda (package)
+                   (package-job store (job-name package)
+                                package system))
+                 packages)))
+         (('manifests . rest)
+          ;; Build packages in the list of manifests.
+          (let* ((manifests (arguments->manifests rest channels))
+                 (packages (manifests->packages store manifests)))
+            (map (lambda (package)
+                   (package-job store (job-name package)
+                                package system))
+                 packages)))
+         (else
+          (error "unknown subset" subset))))
+     systems)))

gnu/installer/parted.scm

@@ -41,6 +41,7 @@
   #:use-module (ice-9 regex)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -318,7 +319,7 @@ PARTED-OBJECT field equals PARTITION, return #f if not found."
 fail. See rereadpt function in wipefs.c of util-linux for an explanation."
   ;; Kernel always return EINVAL for BLKRRPART on loopdevices.
   (and (not (string-match "/dev/loop*" file-name))
-       (let loop ((try 4))
+       (let loop ((try 16))
          (usleep 250000)
          (let ((in-use? (device-in-use? file-name)))
            (if (and in-use? (> try 0))
@@ -339,15 +340,12 @@ fail. See rereadpt function in wipefs.c of util-linux for an explanation."
 (define (non-install-devices)
   "Return all the available devices, except the busy one, allegedly the
 install device. DEVICE-IS-BUSY? is a parted call, checking if the device is
-mounted. The install image uses an overlayfs so the install device does not
-appear as mounted and won't be considered as busy. So use also DEVICE-IN-USE?
-from (guix build syscalls) module, who will try to re-read the device's
-partition table to determine whether or not it is already used (like sfdisk
-from util-linux)."
+mounted."
+  ;; FIXME: The install image uses an overlayfs so the install device does not
+  ;; appear as mounted and won't be considered as busy.
   (remove (lambda (device)
             (let ((file-name (device-path device)))
-              (or (device-is-busy? device)
-                  (with-delay-device-in-use? file-name))))
+              (device-is-busy? device)))
           (devices)))
 
 
@@ -1390,9 +1388,12 @@ the devices not to be used before returning."
   (let ((device-file-names (map device-path devices)))
     (for-each force-device-sync devices)
     (for-each (lambda (file-name)
-                (let ((in-use? (with-delay-device-in-use? file-name)))
-                  (and in-use?
-                       (error
-                        (format #f (G_ "Device ~a is still in use.")
-                                file-name)))))
+                (let/time ((time in-use?
+                                 (with-delay-device-in-use? file-name)))
+                  (if in-use?
+                      (error
+                       (format #f (G_ "Device ~a is still in use.")
+                               file-name))
+                      (syslog "Syncing ~a took ~a seconds.~%"
+                              file-name (time-second time)))))
               device-file-names)))

gnu/installer/utils.scm

@@ -22,6 +22,7 @@
   #:use-module (guix build utils)
   #:use-module (guix i18n)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-34)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
@@ -36,6 +37,8 @@
 
             syslog-port
             syslog
+            call-with-time
+            let/time
 
             with-server-socket
             current-server-socket
@@ -117,6 +120,17 @@ COMMAND exited successfully, #f otherwise."
 ;;; Logging.
 ;;;
 
+(define (call-with-time thunk kont)
+  "Call THUNK and pass KONT the elapsed time followed by THUNK's return
+values."
+  (let* ((start  (current-time time-monotonic))
+         (result (call-with-values thunk list))
+         (end    (current-time time-monotonic)))
+    (apply kont (time-difference end start) result)))
+
+(define-syntax-rule (let/time ((time result exp)) body ...)
+  (call-with-time (lambda () exp) (lambda (time result) body ...)))
+
 (define (open-syslog-port)
   "Return an open port (a socket) to /dev/log or #f if that wasn't possible."
   (let ((sock (socket AF_UNIX SOCK_DGRAM 0)))

gnu/packages/bioinformatics.scm

@@ -12,7 +12,7 @@
 ;;; Copyright © 2018 Joshua Sierles, Nextjournal <joshua@nextjournal.com>
 ;;; Copyright © 2018 Gábor Boskovits <boskovits@gmail.com>
 ;;; Copyright © 2018, 2019, 2020 Mădălin Ionel Patrașcu <madalinionel.patrascu@mdc-berlin.de>
-;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2019, 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2019 Brian Leung <bkleung89@gmail.com>
 ;;; Copyright © 2019 Brett Gilio <brettg@gnu.org>
 ;;; Copyright © 2020 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
@@ -1894,7 +1894,7 @@ multiple sequence alignments.")
 (define-public python-pysam
   (package
     (name "python-pysam")
-    (version "0.15.1")
+    (version "0.16.0.1")
     (source (origin
               (method git-fetch)
               ;; Test data is missing on PyPi.
@@ -1904,7 +1904,7 @@ multiple sequence alignments.")
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "1vj367w6xbn9bpmksm162l1aipf7cj97h1q83y7jcpm33ihwpf7x"))
+                "168bwwm8c2k22m7paip8q0yajyl7xdxgnik0bgjl7rhqg0majz0f"))
               (modules '((guix build utils)))
               (snippet '(begin
                           ;; Drop bundled htslib. TODO: Also remove samtools
@@ -1934,8 +1934,13 @@ multiple sequence alignments.")
              ;; This file contains tests that require a connection to the
              ;; internet.
              (delete-file "tests/tabix_test.py")
-             ;; FIXME: This test fails
+             ;; These tests fail (see:
+             ;; https://github.com/pysam-developers/pysam/issues/939).
+             (delete-file "tests/compile_test.py")
              (delete-file "tests/AlignmentFile_test.py")
+             (delete-file "tests/AlignmentFileHeader_test.py")
+             (delete-file "tests/StreamFiledescriptors_test.py")
+             (delete-file "tests/VariantRecord_test.py")
              ;; Add first subdirectory of "build" directory to PYTHONPATH.
              (setenv "PYTHONPATH"
                      (string-append
@@ -1965,7 +1970,8 @@ multiple sequence alignments.")
        ;; Dependencies below are are for tests only.
        ("samtools" ,samtools)
        ("bcftools" ,bcftools)
-       ("python-nose" ,python-nose)))
+       ("python-nose" ,python-nose)
+       ("python-pytest" ,python-pytest)))
     (home-page "https://github.com/pysam-developers/pysam")
     (synopsis "Python bindings to the SAMtools C API")
     (description

gnu/packages/package-management.scm

@@ -130,9 +130,9 @@
   ;; Latest version of Guix, which may or may not correspond to a release.
   ;; Note: the 'update-guix-package.scm' script expects this definition to
   ;; start precisely like this.
-  (let ((version "1.1.0")
-        (commit "5e7cf66fb35780f930ad0bc5fe21ac330df4411d")
-        (revision 32))
+  (let ((version "1.2.0")
+        (commit "bd96e6d34e4e65dc37eaae7302033d0da287c1e2")
+        (revision 1))
     (package
       (name "guix")
 
@@ -148,7 +148,7 @@
                       (commit commit)))
                 (sha256
                  (base32
-                  "15clfjp845gvl0p6qw0b1gdibqfq20zwzr6dbxvq8l9fgzj1kb6b"))
+                  "0j27yw6s89rni39dmjdz3i617ddr2yi5y5hj0i2a7sw8fn215hp4"))
                 (file-name (string-append "guix-" version "-checkout"))))
       (build-system gnu-build-system)
       (arguments
@@ -336,7 +336,13 @@ $(prefix)/etc/init.d\n")))
                             (let ((bash (assoc-ref inputs "bash")))
                               (substitute* (string-append out "/bin/guix")
                                 (("^#!.*/bash") (string-append "#! " bash "/bin/bash")))))
-                          #t))))))
+                          #t)))
+
+                    ;; The 'guix' executable has 'OUT/libexec/guix/guile' as
+                    ;; its shebang; that should remain unchanged, thus remove
+                    ;; the 'patch-shebangs' phase, which would otherwise
+                    ;; change it to 'GUILE/bin/guile'.
+                    (delete 'patch-shebangs))))
       (native-inputs `(("pkg-config" ,pkg-config)
 
                        ;; Guile libraries are needed here for

gnu/packages/xfce.scm

@@ -787,6 +787,7 @@ on the screen.")
                                           "/tmp/final.jpg")
                                   (copy-file "/tmp/final.jpg" image))
                                 '(;; "backgrounds/xfce-blue.jpg"
+                                  "backgrounds/xfce-stripes.png"
                                   "backgrounds/xfce-teal.jpg"))
                       #t)))
 

gnu/services/base.scm

@@ -62,7 +62,8 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
-  #:re-export (user-processes-service-type)       ;backwards compatibility
+  #:re-export (user-processes-service-type        ;backwards compatibility
+               %default-substitute-urls)
   #:export (fstab-service-type
             root-file-system-service
             file-system-service-type
@@ -106,6 +107,12 @@
             agetty-service-type
 
             mingetty-configuration
+            mingetty-configuration-tty
+            mingetty-configuration-auto-login
+            mingetty-configuration-login-program
+            mingetty-configuration-login-pause?
+            mingetty-configuration-clear-on-logout?
+            mingetty-configuration-mingetty
             mingetty-configuration?
             mingetty-service
             mingetty-service-type

gnu/services/sddm.scm

@@ -169,7 +169,7 @@ Relogin="              (if (sddm-configuration-relogin? config)
 
   (list (shepherd-service
          (documentation "SDDM display manager.")
-         (requirement '(user-processes))
+         (requirement '(user-processes elogind))
          (provision '(xorg-server display-manager))
          (start #~(make-forkexec-constructor #$sddm-command))
          (stop #~(make-kill-destructor)))))

gnu/services/shepherd.scm

@@ -224,16 +224,21 @@ which is not provided by any service")
 
   (for-each assert-satisfied-requirements services))
 
+(define %store-characters
+  ;; Valid store characters; see 'checkStoreName' in the daemon.
+  (string->char-set
+   "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))
+
 (define (shepherd-service-file-name service)
   "Return the file name where the initialization code for SERVICE is to be
 stored."
   (let ((provisions (string-join (map symbol->string
                                       (shepherd-service-provision service)))))
     (string-append "shepherd-"
-                   (string-map (match-lambda
-                                 (#\/ #\-)
-                                 (#\  #\-)
-                                 (chr chr))
+                   (string-map (lambda (chr)
+                                 (if (char-set-contains? %store-characters chr)
+                                     chr
+                                     #\-))
                                provisions)
                    ".scm")))
 

guix/scripts/build.scm

@@ -51,7 +51,9 @@
   #:use-module ((guix progress) #:select (current-terminal-columns))
   #:use-module ((guix build syscalls) #:select (terminal-columns))
   #:use-module (guix transformations)
-  #:export (%standard-build-options
+  #:export (log-url
+
+            %standard-build-options
             set-build-options-from-command-line
             set-build-options-from-command-line*
             show-build-options-help
@@ -179,8 +181,6 @@ options handled by 'set-build-options-from-command-line', and listed in
   -c, --cores=N          allow the use of up to N CPU cores for the build"))
   (display (G_ "
   -M, --max-jobs=N       allow at most N build jobs"))
-  (display (G_ "
-      --help-transform   list package transformation options not shown here"))
   (display (G_ "
       --debug=LEVEL      produce debugging output at LEVEL")))
 
@@ -317,14 +317,7 @@ use '--no-offload' instead~%")))
                     (if c
                         (apply values (alist-cons 'max-jobs c result) rest)
                         (leave (G_ "not a number: '~a' option argument: ~a~%")
-                               name arg)))))
-        (option '("help-transform") #f #f
-                (lambda _
-                  (format #t
-                          (G_ "Available package transformation options:~%"))
-                  (show-transformation-options-help)
-                  (newline)
-                  (exit 0)))))
+                               name arg)))))))
 
 
 ;;;
@@ -381,6 +374,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "

guix/scripts/environment.scm

@@ -180,6 +180,8 @@ COMMAND or an interactive shell in that environment.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "

guix/scripts/graph.scm

@@ -35,7 +35,8 @@
   #:use-module ((guix diagnostics)
                 #:select (location-file formatted-message))
   #:use-module ((guix transformations)
-                #:select (options->transformation
+                #:select (show-transformation-options-help
+                          options->transformation
                           %transformation-options))
   #:use-module ((guix scripts build)
                 #:select (%standard-build-options))
@@ -546,6 +547,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
   (display (G_ "
   -L, --load-path=DIR    prepend DIR to the package module search path"))
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "

guix/scripts/install.scm

@@ -39,6 +39,8 @@ This is an alias for 'guix package -i'.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "

guix/scripts/pack.scm

@@ -59,11 +59,16 @@
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:export (compressor?
+            compressor-name
+            compressor-extenstion
+            compressor-command
+            %compressors
             lookup-compressor
             self-contained-tarball
             docker-image
             squashfs-image
 
+            %formats
             guix-pack))
 
 ;; Type of a compression tool.
@@ -1062,6 +1067,8 @@ last resort for relocation."
 Create a bundle of PACKAGE.\n"))
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -f, --format=FORMAT    build a pack in the given FORMAT"))
   (display (G_ "

guix/scripts/package.scm

@@ -398,6 +398,8 @@ Install, remove, or upgrade packages in a single transaction.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "

guix/scripts/publish.scm

@@ -2,6 +2,7 @@
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org>
 ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -250,6 +251,21 @@ usage."
     ("WantMassQuery" . 0)
     ("Priority" . 100)))
 
+;;; A common buffer size value used for the TCP socket SO_SNDBUF option and
+;;; the gzip compressor buffer size.
+(define %default-buffer-size
+  (* 208 1024))
+
+(define %default-socket-options
+  ;; List of options passed to 'setsockopt' when transmitting files.
+  (list (list SO_SNDBUF %default-buffer-size)))
+
+(define* (configure-socket socket #:key (level SOL_SOCKET)
+                           (options %default-socket-options))
+  "Apply multiple option tuples in OPTIONS to SOCKET, using LEVEL."
+  (for-each (cut apply setsockopt socket level <>)
+            options))
+
 (define (signed-string s)
   "Sign the hash of the string S with the daemon's key.  Return a canonical
 sexp for the signature."
@@ -569,7 +585,7 @@ requested using POOL."
        (lambda (port)
          (write-file item port))
        #:level (compression-level compression)
-       #:buffer-size (* 128 1024))
+       #:buffer-size %default-buffer-size)
      (rename-file (string-append nar ".tmp") nar))
     ('lzip
      ;; Note: the file port gets closed along with the lzip port.
@@ -866,7 +882,7 @@ or if EOF is reached."
      ;; 'make-gzip-output-port' wants a file port.
      (make-gzip-output-port (response-port response)
                             #:level level
-                            #:buffer-size (* 64 1024)))
+                            #:buffer-size %default-buffer-size))
     (($ <compression> 'lzip level)
      (make-lzip-output-port (response-port response)
                             #:level level))
@@ -891,8 +907,7 @@ blocking."
                                             client))
                (port        (begin
                               (force-output client)
-                              (setsockopt client SOL_SOCKET
-                                          SO_SNDBUF (* 128 1024))
+                              (configure-socket client)
                               (nar-response-port response compression))))
           ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in
           ;; 'render-nar', BODY here is just the file name of the store item.
@@ -922,7 +937,7 @@ blocking."
                                                                          size)
                                                     client))
                           (output   (response-port response)))
-                     (setsockopt client SOL_SOCKET SO_SNDBUF (* 128 1024))
+                     (configure-socket client)
                      (if (file-port? output)
                          (sendfile output input size)
                          (dump-port input output))
@@ -1067,7 +1082,8 @@ methods, return the applicable compression."
 (define (open-server-socket address)
   "Return a TCP socket bound to ADDRESS, a socket address."
   (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
-    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (configure-socket sock #:options (cons (list SO_REUSEADDR 1)
+                                           %default-socket-options))
     (bind sock address)
     sock))
 

guix/scripts/pull.scm

@@ -385,7 +385,7 @@ previous generation.  Return true if there are news to display."
     (and=> (relative-generation profile -1)
            (cut generation-file-name profile <>)))
 
-  (when previous
+  (and previous
     (let ((old-channels (profile-channels previous))
           (new-channels (profile-channels profile)))
       ;; Find the channels present in both PROFILE and PREVIOUS, and print

guix/scripts/upgrade.scm

@@ -42,6 +42,8 @@ This is an alias for 'guix package -u'.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "

guix/self.scm

@@ -400,6 +400,12 @@ a list of extra files, such as '(\"contributing\")."
                         (find-files directory
                                     "\\.[a-z]{2}(_[A-Z]{2})?\\.po$")))
 
+          (define parallel-jobs
+            ;; Limit thread creation by 'n-par-for-each'.  Going beyond can
+            ;; lead libgc 8.0.4 to abort with:
+            ;; mmap(PROT_NONE) failed
+            (min (parallel-job-count) 4))
+
           (mkdir #$output)
           (copy-recursively #$documentation "."
                             #:log (%make-void-port "w"))
@@ -415,14 +421,14 @@ a list of extra files, such as '(\"contributing\")."
           (setenv "LC_ALL" "en_US.UTF-8")
           (setlocale LC_ALL "en_US.UTF-8")
 
-          (n-par-for-each (parallel-job-count)
+          (n-par-for-each parallel-jobs
                           (match-lambda
                             ((language . po)
                              (translate-texi "guix" po language
                                              #:extras '("contributing"))))
                           (available-translations "." "guix-manual"))
 
-          (n-par-for-each (parallel-job-count)
+          (n-par-for-each parallel-jobs
                           (match-lambda
                             ((language . po)
                              (translate-texi "guix-cookbook" po language)))

guix/transformations.scm

@@ -508,9 +508,17 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
           (option '("with-debug-info") #t #f
                   (parser 'with-debug-info))
           (option '("without-tests") #t #f
-                  (parser 'without-tests)))))
+                  (parser 'without-tests))
 
-(define (show-transformation-options-help)
+          (option '("help-transform") #f #f
+                  (lambda _
+                    (format #t
+                            (G_ "Available package transformation options:~%"))
+                    (show-transformation-options-help/detailed)
+                    (newline)
+                    (exit 0))))))
+
+(define (show-transformation-options-help/detailed)
   (display (G_ "
       --with-source=[PACKAGE=]SOURCE
                          use SOURCE when building the corresponding package"))
@@ -539,6 +547,10 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
       --without-tests=PACKAGE
                          build PACKAGE without running its tests")))
 
+(define (show-transformation-options-help)
+  "Show basic help for package transformation options."
+  (display (G_ "
+      --help-transform   list package transformation options not shown here")))
 
 (define (options->transformation opts)
   "Return a procedure that, when passed an object to build (package,

po/doc/guix-manual.fr.po

@@ -41,7 +41,7 @@ msgstr ""
 "Project-Id-Version: guix-manual 1.2.0-pre3\n"
 "Report-Msgid-Bugs-To: bug-guix@gnu.org\n"
 "POT-Creation-Date: 2020-11-05 17:27+0100\n"
-"PO-Revision-Date: 2020-11-09 00:09+0100\n"
+"PO-Revision-Date: 2020-11-24 17:52+0100\n"
 "Last-Translator: Julien Lepiller <julien@lepiller.eu>\n"
 "Language-Team: French <traduc@traduc.org>\n"
 "Language: fr\n"
@@ -658,7 +658,7 @@ msgstr "La distribution GNU est jeune et vos paquets préférés peuvent manquer
 #. type: Plain text
 #: doc/contributing.texi:339
 msgid "Free software packages are usually distributed in the form of @dfn{source code tarballs}---typically @file{tar.gz} files that contain all the source files.  Adding a package to the distribution means essentially two things: adding a @dfn{recipe} that describes how to build the package, including a list of other packages required to build it, and adding @dfn{package metadata} along with that recipe, such as a description and licensing information."
-msgstr "Les paquets de logiciels libres sont habituellement distribués sous forme @dfn{d'archives de sources} — typiquement des fichiers @file{.tar.gz} contenant tous les fichiers sources.  Ajouter un paquet à la distribution signifie essentiellement deux choses : ajouter une @dfn{recette} qui décrit comment construire le paquet, avec une liste d'autres paquets requis pour le construire, et ajouter des @dfn{métadonnées de paquet} avec la recette, comme une description et une licence."
+msgstr "Les paquets de logiciels libres sont habituellement distribués sous forme @dfn{d'archives de sources} — typiquement des fichiers @file{.tar.gz} contenant tous les fichiers sources.  Ajouter un paquet à la distribution signifie en substance deux choses : ajouter une @dfn{recette} qui décrit comment construire le paquet, avec une liste d'autres paquets requis pour le construire, et ajouter des @dfn{métadonnées de paquet} avec la recette, comme une description et une licence."
 
 #. type: Plain text
 #: doc/contributing.texi:348
@@ -10698,7 +10698,7 @@ msgstr "Le format nar est comparable dans l'esprit au format \"tar\", mais avec
 #. type: Plain text
 #: doc/guix.texi:4747
 msgid "That nar bundle format is essentially the concatenation of zero or more nars along with metadata for each store item it contains: its file name, references, corresponding derivation, and a digital signature."
-msgstr "Ce format nar bundle est essentiellement la concaténation de zéro ou plus de nar avec des métadonnées pour chaque élément du dépôt qu'il contient : son nom de fichier, ses références, la dérivation correspondante et une signature numérique."
+msgstr "Ce format de lot nar est surtout la concaténation de zéro, un ou plusieurs nar avec des métadonnées pour chaque élément du dépôt qu'il contient : son nom de fichier, ses références, la dérivation correspondante et une signature numérique."
 
 #. type: Plain text
 #: doc/guix.texi:4753
@@ -11226,12 +11226,9 @@ msgstr ""
 " (version 0)\n"
 " (dependencies\n"
 "  (channel\n"
-"   (name une-collection)\n"
-"   (url \"https://exemple.org/premiere-collection.git\"))\n"
-"  (channel\n"
-"   (name une-autre-collection)\n"
-"   (url \"https://exemple.org/deuxieme-collection.git\")\n"
-"   (branch \"testing\"))))\n"
+"   (name 'some-collection)\n"
+"   (url \"https://example.org/first-collection.git\")\n"
+"\n"
 
 #. type: lisp
 #: doc/guix.texi:5151
@@ -11249,7 +11246,7 @@ msgid ""
 "   (url \"https://example.org/second-collection.git\")\n"
 "   (branch \"testing\"))))\n"
 msgstr ""
-"   ;; La partie \"introduction\" ci-dessous est facultative : vous la\n"
+"   ;; La partie « introduction » ci-dessous est facultative : vous la\n"
 "   ;; fournissez pour les dépendances qui peuvent être authentifiées.\n"
 "   (introduction\n"
 "    (channel-introduction\n"
@@ -12361,7 +12358,7 @@ msgstr "Produire des @dfn{binaires repositionnables} — c.-à-d.@: des binaires
 #. type: table
 #: doc/guix.texi:5890
 msgid "When this option is passed once, the resulting binaries require support for @dfn{user namespaces} in the kernel Linux; when passed @emph{twice}@footnote{Here's a trick to memorize it: @code{-RR}, which adds PRoot support, can be thought of as the abbreviation of ``Really Relocatable''.  Neat, isn't it?}, relocatable binaries fall to back to other techniques if user namespaces are unavailable, and essentially work anywhere---see below for the implications."
-msgstr "Lorsque vous passez cette option une fois, les binaires qui en résultent demandent le support des @dfn{espaces de nom utilisateurs} dans le noyau Linux ; lorsque vous la passez @emph{deux fois}@footnote{Il y a une astuce pour s'en souvenir : on peut envisager @code{-RR}, qui ajoute le support PRoot, comme étant l'abréviation de « Réellement Repositionnable ».  Pas mal, hein ?}, les binaires repositionnables utilisent PRoot si les espaces de noms ne sont pas utilisables, et ça fonctionne partout — voir plus bas pour comprendre les implications."
+msgstr "Lorsque vous passez cette option une fois, les binaires qui en résultent demandent le support des @dfn{espaces de nom utilisateurs} dans le noyau Linux ; lorsque vous la passez @emph{deux fois}@footnote{Il y a une astuce pour s'en souvenir : on peut envisager @code{-RR}, qui ajoute le support PRoot, comme étant l'abréviation de « Réellement Repositionnable ».  Pas mal, hein ?}, les binaires repositionnables utilisent PRoot si les espaces de noms ne sont pas utilisables, et ça fonctionne à peu près partout — voir plus bas pour comprendre les implications."
 
 #. type: table
 #: doc/guix.texi:5892
@@ -12875,7 +12872,7 @@ msgstr "En ajoutant le répertoire contenant vos modules de paquets au chemin de
 #. type: enumerate
 #: doc/guix.texi:6264
 msgid "By defining a @dfn{channel} and configuring @command{guix pull} so that it pulls from it.  A channel is essentially a Git repository containing package modules.  @xref{Channels}, for more information on how to define and use channels."
-msgstr "En définissant un @dfn{canal} et en configurant @command{guix pull} pour qu'il l'utilise.  Un canal est essentiellement un dépôt Git contenant des modules de paquets.  @xref{Channels}, pour plus d'informations sur comment définir et utiliser des canaux."
+msgstr "En définissant un @dfn{canal} et en configurant @command{guix pull} pour qu'il l'utilise.  Un canal est en substance un dépôt Git contenant des modules de paquets.  @xref{Channels}, pour plus d'informations sur comment définir et utiliser des canaux."
 
 #. type: Plain text
 #: doc/guix.texi:6267
@@ -12968,7 +12965,7 @@ msgstr ""
 #. type: Plain text
 #: doc/guix.texi:6325
 msgid "Without being a Scheme expert, the reader may have guessed the meaning of the various fields here.  This expression binds the variable @code{hello} to a @code{<package>} object, which is essentially a record (@pxref{SRFI-9, Scheme records,, guile, GNU Guile Reference Manual}).  This package object can be inspected using procedures found in the @code{(guix packages)} module; for instance, @code{(package-name hello)} returns---surprise!---@code{\"hello\"}."
-msgstr "Sans être un expert Scheme, le lecteur peut comprendre la signification des différents champs présents.  Cette expression lie la variable @code{hello} à un objet @code{<package>}, qui est essentiellement un enregistrement (@pxref{SRFI-9, Scheme records,, guile, GNU Guile Reference Manual}).  On peut inspecter cet objet de paquet avec les procédures qui se trouvent dans le module @code{(guix packages)} ; par exemple, @code{(package-name hello)} renvoie — oh surprise ! — @code{\"hello\"}."
+msgstr "Sans être un expert Scheme, le lecteur peut comprendre la signification des différents champs présents.  Cette expression lie la variable @code{hello} à un objet @code{<package>}, qui est en substance un enregistrement (@pxref{SRFI-9, Scheme records,, guile, GNU Guile Reference Manual}).  On peut inspecter cet objet de paquet avec les procédures qui se trouvent dans le module @code{(guix packages)} ; par exemple, @code{(package-name hello)} renvoie — oh surprise ! — @code{\"hello\"}."
 
 #. type: Plain text
 #: doc/guix.texi:6329
@@ -13959,7 +13956,7 @@ msgstr ""
 #. type: Plain text
 #: doc/guix.texi:6888
 msgid "The example above corresponds to what the @option{--with-source} package transformation option does.  Essentially @code{hello-2.2} preserves all the fields of @code{hello}, except @code{version} and @code{source}, which it overrides.  Note that the original @code{hello} variable is still there, in the @code{(gnu packages base)} module, unchanged.  When you define a custom package like this, you are really @emph{adding} a new package definition; the original one remains available."
-msgstr "L'exemple ci-dessus correspond à ce que l'option de transformation des paquets @option{--with-source} fait.  Essentiellement, @code{hello-2.2} préserve tous les champs de @code{hello}, sauf @code{version} et @code{source}, qu'il remplace.  Remarquez que la variable @code{hello} originale est toujours là, dans le module @code{(gnu packages base)}, et n'est pas modifiée.  Lorsque vous définissez un paquet personnalisé comme ceci, vous @emph{ajoutez} en fait une nouvelle définition de paquet ; la version originale est toujours disponible."
+msgstr "L'exemple ci-dessus correspond à ce que l'option de transformation des paquets @option{--with-source} fait.  En substance, @code{hello-2.2} préserve tous les champs de @code{hello}, sauf @code{version} et @code{source}, qu'il remplace.  Remarquez que la variable @code{hello} originale est toujours là, dans le module @code{(gnu packages base)}, et n'est pas modifiée.  Lorsque vous définissez un paquet personnalisé comme ceci, vous @emph{ajoutez} en fait une nouvelle définition de paquet ; la version originale est toujours disponible."
 
 #. type: Plain text
 #: doc/guix.texi:6894
@@ -14997,7 +14994,7 @@ msgstr "{Variable Scheme} julia-build-system"
 #. type: defvr
 #: doc/guix.texi:7550
 msgid "This variable is exported by @code{(guix build-system julia)}.  It implements the build procedure used by @uref{https://julialang.org/, julia} packages, which essentially is similar to running @samp{julia -e 'using Pkg; Pkg.add(package)'} in an environment where @env{JULIA_LOAD_PATH} contains the paths to all Julia package inputs.  Tests are run with @code{Pkg.test}."
-msgstr "Cette variable est exportée par @code{(guix build-system julia)}.  Elle implémente la procédure de compilation utilisée par les paquets @uref{https://julialang.org/, julia}, qui est essentiellement similaire à l'exécution de @samp{julia -e 'using Pkg ; Pkg.add(package)'} dans un environnement où @env{JULIA_LOAD_PATH} contient les chemins de toutes les entrées des paquets Julia. Les tests sont effectués avec @code{Pkg.test}."
+msgstr "Cette variable est exportée par @code{(guix build-system julia)}.  Elle implémente la procédure de compilation utilisée par les paquets @uref{https://julialang.org/, julia}, qui est globalement similaire à l'exécution de @samp{julia -e 'using Pkg ; Pkg.add(package)'} dans un environnement où @env{JULIA_LOAD_PATH} contient les chemins de toutes les entrées des paquets Julia. Les tests sont effectués avec @code{Pkg.test}."
 
 #. type: defvr
 #: doc/guix.texi:7553
@@ -15221,7 +15218,7 @@ msgstr "{Variable Scheme} r-build-system"
 #. type: defvr
 #: doc/guix.texi:7753
 msgid "This variable is exported by @code{(guix build-system r)}.  It implements the build procedure used by @uref{https://r-project.org, R} packages, which essentially is little more than running @samp{R CMD INSTALL --library=/gnu/store/@dots{}} in an environment where @env{R_LIBS_SITE} contains the paths to all R package inputs.  Tests are run after installation using the R function @code{tools::testInstalledPackage}."
-msgstr "Cette variable est exportée par @code{(guix build-system r)}.  Elle implémente la procédure de compilation utilisée par les paquets @uref{https://r-project.org, R}, qui consiste essentiellement à exécuter @samp{R CMD INSTALL --library=/gnu/store/@dots{}} dans un environnement où @env{R_LIBS_SITE} contient les chemins de toutes les entrées des paquets R.  Les tests sont exécutés après l'installation en utilisant la fonction R @code{tools::testInstalledPackage}."
+msgstr "Cette variable est exportée par @code{(guix build-system r)}.  Elle implémente la procédure de compilation utilisée par les paquets @uref{https://r-project.org, R}, qui consiste en substance à exécuter @samp{R CMD INSTALL --library=/gnu/store/@dots{}} dans un environnement où @env{R_LIBS_SITE} contient les chemins de toutes les entrées des paquets R.  Les tests sont exécutés après l'installation en utilisant la fonction R @code{tools::testInstalledPackage}."
 
 #. type: defvr
 #: doc/guix.texi:7755
@@ -15991,7 +15988,7 @@ msgstr "{Procédure Scheme} copy-recursively @var{source} @var{destination} @"
 #: doc/guix.texi:8277
 msgid "[#:log (current-output-port)] [#:follow-symlinks? #f] [#:keep-mtime? #f] Copy @var{source} directory to @var{destination}.  Follow symlinks if @var{follow-symlinks?} is true; otherwise, just preserve them.  When @var{keep-mtime?} is true, keep the modification time of the files in @var{source} on those of @var{destination}.  Write verbose output to the @var{log} port."
 msgstr ""
-"[#:log (current-output-port)] [#:follow-symlinks ? #f] [#:keep-mtime ? #f] \n"
+"[#:log (current-output-port)] [#:follow-symlinks? #f] [#:keep-mtime? #f] \n"
 "Copie le répertoire @var{source} dans @var{destination}.  Suivez les liens symboliques si @var{follow-symlinks?} est vrai ; sinon, conservez-les.  Lorsque @var{keep-mtime?} est vrai, conservez les heures de modification des fichiers dans @var{source} sur celles de @var{destination}.  Écrivez une sortie verbeuse sur le port @var{log}."
 
 #. type: deffn
@@ -16094,7 +16091,7 @@ msgstr "{Procédure Scheme} find-files @var{dir} [@var{pred}] @"
 #: doc/guix.texi:8336
 msgid "[#:stat lstat] [#:directories? #f] [#:fail-on-error? #f] Return the lexicographically sorted list of files under @var{dir} for which @var{pred} returns true.  @var{pred} is passed two arguments: the absolute file name, and its stat buffer; the default predicate always returns true.  @var{pred} can also be a regular expression, in which case it is equivalent to @code{(file-name-predicate @var{pred})}.  @var{stat} is used to obtain file information; using @code{lstat} means that symlinks are not followed.  If @var{directories?} is true, then directories will also be included.  If @var{fail-on-error?} is true, raise an exception upon error."
 msgstr ""
-"[#:stat lstat] [#:directories ? #f] [#:fail-on-error ? #f] \n"
+"[#:stat lstat] [#:directories? #f] [#:fail-on-error? #f] \n"
 "Renvoie la liste des fichiers triés lexicographiquement sous @var{dir} pour lesquels @var{pred} renvoie « vrai ».  Deux arguments sont passés à @var{pred} : le nom absolu du fichier et son tampon stat ; le prédicat par défaut renvoie toujours « vrai ».  @var{pred} peut également être une expression régulière, auquel cas elle est équivalente à @code{(file-name-predicate @var{pred})}.  @var{stat} est utilisé pour obtenir des informations sur les fichiers ; l'utilisation de @code{lstat} signifie que les liens symboliques ne sont pas suivis.  Si @var{directories?} est vrai, alors les répertoires seront également inclus.  Si @var{fail-on-error?} est vrai, il lance une exception en cas d'erreur."
 
 #. type: Plain text
@@ -18835,7 +18832,7 @@ msgstr "Produire une sortie de débogage qui provient du démon de construction.
 #. type: Plain text
 #: doc/guix.texi:10046
 msgid "Behind the scenes, @command{guix build} is essentially an interface to the @code{package-derivation} procedure of the @code{(guix packages)} module, and to the @code{build-derivations} procedure of the @code{(guix derivations)} module."
-msgstr "Sous le capot, @command{guix build} est surtout un interface à la procédure @code{package-derivation} du module @code{(guix packages)}, et à la procédure @code{build-derivations} du module @code{(guix derivations)}."
+msgstr "Sous le capot, @command{guix build} est surtout une interface à la procédure @code{package-derivation} du module @code{(guix packages)}, et à la procédure @code{build-derivations} du module @code{(guix derivations)}."
 
 #. type: Plain text
 #: doc/guix.texi:10050
@@ -20766,7 +20763,7 @@ msgstr "guix refresh -l -e '(@@@@ (gnu packages commencement) glibc-final)'\n"
 #. type: table
 #: doc/guix.texi:11317
 msgid "This command lists the dependents of the ``final'' libc (essentially all the packages)."
-msgstr "Cette commande liste les dépendances de la libc « finale » (essentiellement tous les paquets)."
+msgstr "Cette commande liste les dépendances de la libc « finale » (presque tous les paquets)."
 
 #. type: item
 #: doc/guix.texi:11318
@@ -23567,17 +23564,19 @@ msgid ""
 "\n"
 msgstr ""
 "(define %my-services\n"
-"  ;; Ma propre liste de services.\n"
+"  ;; ma propre liste de services.\n"
 "  (modify-services %base-services\n"
 "    (guix-service-type config =>\n"
 "                       (guix-configuration\n"
 "                        (inherit config)\n"
-"                        (use-substitutes? #f)\n"
-"                        (extra-options '(\"--gc-keep-derivations\"))))\n"
+"                        ;; Récupérer les substituts depuis example.org.\n"
+"                        (substitute-urls\n"
+"                          (list \"https://example.org/guix\"\n"
+"                                \"https://ci.guix.gnu.org\"))))\n"
 "    (mingetty-service-type config =>\n"
 "                           (mingetty-configuration\n"
-"                            (inherit config)))))\n"
-"                            ;; Automatially log in as \"guest\".\n"
+"                            (inherit config)\n"
+"                            ;; Connexion automatique en tant que « guest ».\n"
 "                            (auto-login \"guest\")))))\n"
 "\n"
 
@@ -25029,7 +25028,7 @@ msgstr ""
 "                          \"audio\"   ;carte son\n"
 "                          \"video\"   ;périphériques réseaux comme les webcams\n"
 "                          \"cdrom\")) ;le bon vieux CD-ROM\n"
-"  (comment \"Bob's sister\")\n"
+"  (comment \"Bob's sister\"))\n"
 
 #. type: Plain text
 #: doc/guix.texi:13865

tests/build-utils.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -174,7 +174,7 @@ echo hello world"))
        (let ((script-file-name (string-append directory "/foo")))
          (call-with-output-file script-file-name
            (lambda (port)
-             (format port script-contents)))
+             (display script-contents port)))
          (chmod script-file-name #o777)
          (wrap-script script-file-name
                       `("GUIX_FOO" prefix ("/some/path"