Merge branch 'master' into gnome-team

6 files changed, 80 insertions, 26 deletions

diff --git a/guix/deprecation.scm b/guix/deprecation.scm
index 8147a01e24..47e653dfb2 100644
--- a/guix/deprecation.scm
+++ b/guix/deprecation.scm
@@ -103,7 +103,7 @@ This will write a deprecation warning to GUIX-WARNING-PORT."
        #'(define-deprecated variable alias alias)))))
 
 (define-syntax-rule (define-deprecated/public body ...)
-  "Like 'define/deprecated', but export all the newly introduced bindings."
+  "Like 'define-deprecated', but export all the newly introduced bindings."
   (define-deprecated public body ...))
 
 (define-syntax-rule (define-deprecated/alias deprecated replacement)
diff --git a/guix/download.scm b/guix/download.scm
index 38f5141cb9..21d02ab203 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -117,11 +117,9 @@
        "http://internode.dl.sourceforge.net/project/"
        "http://jaist.dl.sourceforge.net/project/"
        "http://liquidtelecom.dl.sourceforge.net/project/"
-       ;; "http://nbtelecom.dl.sourceforge.net/project/"  ;never returns 404s
        "http://nchc.dl.sourceforge.net/project/"
        "http://netcologne.dl.sourceforge.net/project/"
        "http://netix.dl.sourceforge.net/project/"
-       "http://pilotfiber.dl.sourceforge.net/project/"
        "http://tenet.dl.sourceforge.net/project/")
       (netfilter.org ; https://www.netfilter.org/mirrors.html
        "http://ftp.netfilter.org/pub/"
@@ -133,19 +131,21 @@
        "http://ftp.be.debian.org/pub/"
        "https://mirrors.edge.kernel.org/pub/"
        "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/")
-      (apache             ; from http://www.apache.org/mirrors/dist.html
-       "http://www.eu.apache.org/dist/"
-       "http://www.us.apache.org/dist/"
-       "https://ftp.nluug.nl/internet/apache/"
+      (apache
+       "https://dlcdn.apache.org/"
+       "https://downloads.apache.org/"
+       "https://mirrors.sonic.net/apache/"
+       "https://apache.osuosl.org/"
+       "https://mirrors.ircam.fr/pub/apache/"
+       "https://apache-mirror.rbc.ru/pub/apache/"
+       "https://mirrors.ibiblio.org/apache/"
+
+       ;; No HTTPS.
        "http://apache.mirror.iweb.ca/"
-       "http://mirrors.ircam.fr/pub/apache/"
        "http://apache.mirrors.ovh.net/ftp.apache.org/dist/"
-       "http://apache-mirror.rbc.ru/pub/apache/"
-       "ftp://ftp.osuosl.org/pub/apache/"
-       "http://mirrors.ibiblio.org/apache/"
 
        ;; As a last resort, try the archive.
-       "http://archive.apache.org/dist/")
+       "https://archive.apache.org/dist/")
       (xorg               ; from http://www.x.org/wiki/Releases/Download
        "http://www.x.org/releases/" ; main mirrors
        "http://mirror.csclub.uwaterloo.ca/x.org/" ; North America
@@ -271,7 +271,6 @@
        "https://mirror.kumi.systems/kde/ftp/"
        "https://mirrors.ircam.fr/pub/KDE/"
        "https://ftp.gwdg.de/pub/linux/kde/"
-       "https://mirrors.gethosted.online/kde/pub/kde/"
        "https://fr2.rpmfind.net/linux/KDE/"
        "https://mirror.faigner.de/kde/ftp/"
        "https://www.mirrorservice.org/sites/download.kde.org/"
@@ -288,7 +287,6 @@
        "https://mirrors.nav.ro/kde/"
        "https://mirrors.xtom.ee/kde/"
        "https://ftp.funet.fi/pub/mirrors/ftp.kde.org/pub/kde/"
-       "https://kde.ip-connect.vn.ua/"
        "https://mirrors.netix.net/kde/"
        "https://ftp.cc.uoc.gr/mirrors/kde/"
        ;; North America
@@ -307,7 +305,7 @@
        "https://mirrors.xtom.jp/kde/"
        "https://mirrors.xtom.hk/kde/"
        ;; Africa
-       "http://mirror.retentionrange.co.bw/kde/"
+       "https://mirror.dimensiondata.com/mirror/ftp.kde.org/"
        ;; Oceania
        "https://mirrors.xtom.au/kde/")
       (openbsd
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 0fe4f1c98a..29819878fa 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -775,6 +775,23 @@ x86_64-linux when COREUTILS is lowered."
 whether this should be considered a \"native\" input or not."
   (%gexp-input thing output native?))
 
+;; Allow <gexp-input>s to be used within gexps.  This is useful when willing
+;; to force a specific reference to an object, as in (gexp-input hwloc "bin"),
+;; which forces a reference to the "bin" output of 'hwloc' instead of leaving
+;; it up to the recipient to pick the right output.
+(define-gexp-compiler gexp-input-compiler <gexp-input>
+  compiler => (lambda (obj system target)
+                (match obj
+                  (($ <gexp-input> thing output native?)
+                   (lower-object thing system
+                                 #:target (and (not native?) target)))))
+  expander => (lambda (obj lowered output/ignored)
+                (match obj
+                  (($ <gexp-input> thing output native?)
+                   (let ((expand (or (lookup-expander thing)
+                                     (lookup-expander lowered))))
+                     (expand thing lowered output))))))
+
 ;; Reference to one of the derivation's outputs, for gexps used in
 ;; derivations.
 (define-record-type <gexp-output>
@@ -917,6 +934,11 @@ When TARGET is true, use it as the cross-compilation target triplet."
 corresponding <derivation-input> or store item."
   (define tuple->gexp-input
     (match-lambda
+      (((? gexp-input? input))
+       ;; This case lets users specify the output of interest more
+       ;; conveniently, for instance by passing (gexp-input hwloc "lib") to
+       ;; the 'references-file' procedure.
+       input)
       ((thing)
        (%gexp-input thing "out" (not target)))
       ((thing output)
@@ -1135,10 +1157,9 @@ applicable.
 When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
 following forms:
 
-  (FILE-NAME PACKAGE)
-  (FILE-NAME PACKAGE OUTPUT)
-  (FILE-NAME DERIVATION)
-  (FILE-NAME DERIVATION OUTPUT)
+  (FILE-NAME OBJ)
+  (FILE-NAME OBJ OUTPUT)
+  (FILE-NAME GEXP-INPUT)
   (FILE-NAME STORE-ITEM)
 
 The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 723a770e41..fe1d32d79a 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -85,6 +85,21 @@
 (define %input-style
   (make-parameter 'variable)) ; or 'specification
 
+(define (format-inputs inputs)
+  "Generate a sorted list of package inputs from a list of upstream inputs."
+  (map (lambda (input)
+         (case (%input-style)
+           ((specification)
+            `(specification->package ,(upstream-input-name input)))
+           (else
+            ((compose string->symbol
+                       upstream-input-downstream-name)
+             input))))
+       (sort inputs
+             (lambda (a b)
+               (string-ci<? (upstream-input-name a)
+                            (upstream-input-name b))))))
+
 (define (string->licenses license-string license-prefix)
   (let ((licenses
          (map string-trim-both
@@ -177,9 +192,7 @@ package definition."
     (()
      '())
     ((package-inputs ...)
-     `((,input-type (list ,@(map (compose string->symbol
-                                          upstream-input-downstream-name)
-                                 package-inputs)))))))
+     `((,input-type (list ,@(format-inputs package-inputs)))))))
 
 (define %cran-url "https://cran.r-project.org/web/packages/")
 (define %cran-canonical-url "https://cran.r-project.org/package=")
@@ -396,6 +409,7 @@ empty list when the FIELD cannot be found."
         "gnu"
         "posix.1-2001"
         "linux"
+        "libR"
         "none"
         "unix"
         "windows"
diff --git a/guix/least-authority.scm b/guix/least-authority.scm
index bfd7275e7c..3465fe9a48 100644
--- a/guix/least-authority.scm
+++ b/guix/least-authority.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2022-2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,6 +41,8 @@
 
 (define* (least-authority-wrapper program
                                   #:key (name "pola-wrapper")
+                                  (user #f)
+                                  (group #f)
                                   (guest-uid 1000)
                                   (guest-gid 1000)
                                   (mappings '())
@@ -55,7 +57,11 @@ symbols; it runs with GUEST-UID and GUEST-GID.  MAPPINGS is a list of
 <file-system-mapping> records indicating directories mirrored inside the
 execution environment of PROGRAM.  DIRECTORY is the working directory of the
 wrapped process.  Each environment listed in PRESERVED-ENVIRONMENT-VARIABLES
-is preserved; other environment variables are erased."
+is preserved; other environment variables are erased.
+
+When USER and GROUP are set and NAMESPACES does not include 'user, change UIDs
+and GIDs to these prior to executing PROGRAM.  This usually requires that the
+resulting wrapper be executed as root so it can call setgid(2) and setuid(2)."
   (define code
     (with-imported-modules (source-module-closure
                             '((gnu system file-systems)
@@ -113,6 +119,10 @@ is preserved; other environment variables are erased."
                                 #$program signal)
                         (exit (+ 128 signal))))))
 
+          (define namespaces '#$namespaces)
+          (define host-group '#$group)
+          (define host-user '#$user)
+
           ;; Note: 'call-with-container' creates a sub-process that this one
           ;; waits for.  This might seem suboptimal but unshare(2) isn't
           ;; really applicable: the process would still run in the same PID
@@ -123,6 +133,17 @@ is preserved; other environment variables are erased."
              (lambda ()
                (chdir #$directory)
                (environ variables)
+
+               (unless (memq 'user namespaces)
+                 ;; This process lives in its parent user namespace,
+                 ;; presumably as root; now is the time to setgid/setuid if
+                 ;; asked for it (the 'clone' call would fail with EPERM if we
+                 ;; changed UIDs/GIDs beforehand).
+                 (when host-group
+                   (setgid (group:gid (getgr host-group))))
+                 (when host-user
+                   (setuid (passwd:uid (getpw host-user)))))
+
                (apply execl #$program #$program (cdr (command-line))))
 
              ;; Don't assume PROGRAM can behave as an init process.
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 0441d3fead..19052d5652 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -55,7 +55,7 @@
     file))
 
 (define (ensure-valid-store-file-name name)
-  "Replace any character not allowed in a stror name by an underscore."
+  "Replace any character not allowed in a store name by an underscore."
 
   (define valid
     ;; according to nix/libstore/store-api.cc