Merge remote-tracking branch 'origin/master' into kde-updates

9 files changed, 128 insertions, 58 deletions

diff --git a/guix/git.scm b/guix/git.scm
index be20cde019..dbc3b7caa7 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -439,7 +439,7 @@ could not be fetched from Software Heritage~%")
                                    #:recursive? recursive?)))
   "Update the cached checkout of URL to REF in CACHE-DIRECTORY.  Return three
 values: the cache directory name, and the SHA1 commit (a string) corresponding
-to REF, and the relation of the new commit relative to STARTING-COMMIT (if
+to REF, and the relation of STARTING-COMMIT relative to the new commit (if
 provided) as returned by 'commit-relation'.
 
 REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm
index b5a812b34e..7e79c77884 100644
--- a/guix/import/texlive.scm
+++ b/guix/import/texlive.scm
@@ -101,6 +101,7 @@
     ("cc-by-sa-3" 'cc-by-sa3.0)
     ("cc-by-sa-4" 'cc-by-sa4.0)
     ("mit" 'expat)
+    ("x11" 'x11)
     ("fdl" 'fdl1.3+)
     ;; The GUST Font Nosource License, which is legally equivalent to
     ;; lppl1.3c+, is no longer in use (per
@@ -298,7 +299,7 @@ When TEXLIVE-ONLY is true, only TeX Live packages are returned."
 (define (linked-scripts name package-database)
   "Return a list of script names to symlink from \"bin/\" directory for
 package NAME according to PACKAGE-DATABASE.  Consider as scripts files with
-\".lua\", \".pl\", \".py\", \".sh\", \".tcl\", \".texlua\", \".tlu\"
+\".lua\", \".pl\", \".py\", \".rb\", \".sh\", \".tcl\", \".texlua\", \".tlu\"
 extensions, and files without extension."
   (and-let* ((data (assoc-ref package-database name))
              ;; Check if binaries are associated to the package.
@@ -317,7 +318,8 @@ extensions, and files without extension."
     (filter-map (lambda (script)
                   (and (any (lambda (ext)
                               (member (basename script ext) binaries))
-                            '(".lua" ".pl" ".py" ".sh" ".tcl" ".texlua" ".tlu"))
+                            '(".lua" ".pl" ".py" ".rb" ".sh" ".tcl" ".texlua"
+                              ".tlu"))
                        (basename script)))
                 ;; Get the right (alphabetic) order.
                 (reverse scripts))))
@@ -476,6 +478,7 @@ of those files are returned that are unexpectedly installed."
           ,@(match (append-map (lambda (s)
                                  (cond ((string-suffix? ".pl" s) '(perl))
                                        ((string-suffix? ".py" s) '(python))
+                                       ((string-suffix? ".rb" s) '(ruby))
                                        ((string-suffix? ".tcl" s) '(tcl tk))
                                        (else '())))
                                (or scripts '()))
@@ -499,7 +502,7 @@ of those files are returned that are unexpectedly installed."
           (license
            ,(cond
              (meta-package?
-              '(license:fsf-free "https://www.tug.org/texlive/copying.html"))
+              '(fsf-free "https://www.tug.org/texlive/copying.html"))
              ((assoc-ref data 'catalogue-license) => string->license)
              (else #f))))
        (translate-depends depends #t)))))
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 5dfd30a6c8..fca6fb4b22 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -871,11 +871,15 @@ prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
                                   #:key
                                   (authenticate? #t)
                                   (cache-directory (%inferior-cache-directory))
-                                  (ttl (* 3600 24 30)))
+                                  (ttl (* 3600 24 30))
+                                  validate-channels)
   "Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
-The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.
-This procedure opens a new connection to the build daemon.  AUTHENTICATE?
-determines whether CHANNELS are authenticated."
+The directory is a subdirectory of CACHE-DIRECTORY, where entries can be
+reclaimed after TTL seconds.  This procedure opens a new connection to the
+build daemon.  AUTHENTICATE? determines whether CHANNELS are authenticated.
+VALIDATE-CHANNELS, if specified, must be a one argument procedure accepting a
+list of channels that can be used to validate the channels; it should raise an
+exception in case of problems."
   (define commits
     ;; Since computing the instances of CHANNELS is I/O-intensive, use a
     ;; cheaper way to get the commit list of CHANNELS.  This limits overhead
@@ -923,27 +927,30 @@ determines whether CHANNELS are authenticated."
 
   (if (file-exists? cached)
       cached
-      (run-with-store store
-        (mlet* %store-monad ((instances
-                              -> (latest-channel-instances store channels
-                                                           #:authenticate?
-                                                           authenticate?))
-                             (profile
-                              (channel-instances->derivation instances)))
-          (mbegin %store-monad
-            ;; It's up to the caller to install a build handler to report
-            ;; what's going to be built.
-            (built-derivations (list profile))
-
-            ;; Cache if and only if AUTHENTICATE? is true.
-            (if authenticate?
-                (mbegin %store-monad
-                  (symlink* (derivation->output-path profile) cached)
-                  (add-indirect-root* cached)
-                  (return cached))
-                (mbegin %store-monad
-                  (add-temp-root* (derivation->output-path profile))
-                  (return (derivation->output-path profile)))))))))
+      (begin
+        (when (procedure? validate-channels)
+          (validate-channels channels))
+        (run-with-store store
+          (mlet* %store-monad ((instances
+                                -> (latest-channel-instances store channels
+                                                             #:authenticate?
+                                                             authenticate?))
+                               (profile
+                                (channel-instances->derivation instances)))
+            (mbegin %store-monad
+              ;; It's up to the caller to install a build handler to report
+              ;; what's going to be built.
+              (built-derivations (list profile))
+
+              ;; Cache if and only if AUTHENTICATE? is true.
+              (if authenticate?
+                  (mbegin %store-monad
+                    (symlink* (derivation->output-path profile) cached)
+                    (add-indirect-root* cached)
+                    (return cached))
+                  (mbegin %store-monad
+                    (add-temp-root* (derivation->output-path profile))
+                    (return (derivation->output-path profile))))))))))
 
 (define* (inferior-for-channels channels
                                 #:key
diff --git a/guix/platforms/powerpc.scm b/guix/platforms/powerpc.scm
index 9d0b343bc3..1c7141ab42 100644
--- a/guix/platforms/powerpc.scm
+++ b/guix/platforms/powerpc.scm
@@ -20,6 +20,7 @@
   #:use-module (guix platform)
   #:use-module (guix records)
   #:export (powerpc-linux
+            powerpc64-linux
             powerpc64le-linux))
 
 (define powerpc-linux
@@ -29,6 +30,13 @@
    (linux-architecture "powerpc")
    (glibc-dynamic-linker "/lib/ld.so.1")))
 
+(define powerpc64-linux
+  (platform
+   (target "powerpc64-linux-gnu")
+   (system #f)                                    ;not supported
+   (linux-architecture "powerpc")
+   (glibc-dynamic-linker "/lib/ld64.so.1")))
+
 (define powerpc64le-linux
   (platform
    (target "powerpc64le-linux-gnu")
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index fbd5689be8..e0800bc062 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -330,6 +330,10 @@ immediately.  Return the exit status of the process in the container."
                  (display "127.0.0.1 localhost\n" port)
                  (chmod port #o444))))
 
+           ;; Create /tmp; bits of code expect it, such as
+           ;; 'least-authority-wrapper'.
+           (mkdir-p "/tmp")
+
            ;; Set PATH for things that the activation script might expect, such
            ;; as "env".
            (load-profile #$system-profile)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index ecd264d3fa..9b78d4b5ca 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -166,7 +166,7 @@ Download and deploy the latest version of Guix.\n"))
                                (alist-delete 'repository-url result))))
          (option '("commit") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'ref `(commit . ,arg) result)))
+                   (alist-cons 'ref `(tag-or-commit . ,arg) result)))
          (option '("branch") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'ref `(branch . ,arg) result)))
@@ -774,7 +774,8 @@ Use '~/.config/guix/channels.scm' instead."))
                (if (guix-channel? c)
                    (let ((url (or url (channel-url c))))
                      (match ref
-                       (('commit . commit)
+                       ((or ('commit . commit)
+                            ('tag-or-commit . commit))
                         (channel (inherit c)
                                  (url url) (commit commit) (branch #f)))
                        (('branch . branch)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index a9241aa20d..f39dc743b1 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -10,6 +10,7 @@
 ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2023 Maxim Cournoyer maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -106,6 +107,9 @@
         (option '(#\m "manifest") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'manifest arg result)))
+        (option '("target-version") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'target-version arg result)))
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression arg result)))
@@ -165,6 +169,9 @@ specified with `--select'.\n"))
   (display (G_ "
   -m, --manifest=FILE    select all the packages from the manifest in FILE"))
   (display (G_ "
+      --target-version=VERSION
+                         update the package or packages to VERSION"))
+  (display (G_ "
   -t, --type=UPDATER,... restrict to updates from the specified updaters
                          (e.g., 'gnu')"))
   (display (G_ "
@@ -213,17 +220,20 @@ specified with `--select'.\n"))
 (define* (update-spec package #:optional version)
   (%update-spec package version))
 
-(define (update-specification->update-spec spec)
+(define (update-specification->update-spec spec fallback-version)
   "Given SPEC, a package name like \"guile@2.0=2.0.8\", return a <update>
-record with two fields: the package to upgrade, and the target version."
+record with two fields: the package to upgrade, and the target version.  When
+SPEC lacks a version, use FALLBACK-VERSION."
   (match (string-rindex spec #\=)
-    (#f  (update-spec (specification->package spec) #f))
+    (#f  (update-spec (specification->package spec) fallback-version))
     (idx (update-spec (specification->package (substring spec 0 idx))
                       (substring spec (1+ idx))))))
 
 (define (options->update-specs opts)
   "Return the list of <update-spec> records requested by OPTS, honoring
 options like '--recursive'."
+  (define target-version (assoc-ref opts 'target-version))
+
   (define core-package?
     (let* ((input->package (match-lambda
                              ((name (? package? package) _ ...) package)
@@ -263,13 +273,18 @@ update would trigger a complete rebuild."
     ;; Update specs explicitly passed as command-line arguments.
     (match (append-map (match-lambda
                          (('argument . spec)
-                          ;; Take either the specified version or the
-                          ;; latest one.
-                          (list (update-specification->update-spec spec)))
+                          ;; Take either the specified version or the latest
+                          ;; one.  The version specified as part of a spec
+                          ;; takes precedence, with the command-line specified
+                          ;; --target-version used as a fallback.
+                          (list (update-specification->update-spec
+                                 spec target-version)))
                          (('expression . exp)
-                          (list (update-spec (read/eval-package-expression exp))))
+                          (list (update-spec (read/eval-package-expression exp)
+                                             target-version)))
                          (('manifest . manifest)
-                          (map update-spec (packages-from-manifest manifest)))
+                          (map (cut update-spec <> target-version)
+                               (packages-from-manifest manifest)))
                          (_
                           '()))
                        opts)
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 9948df0ca6..ff6242ffb4 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -186,22 +186,22 @@ services as defined by OS."
                      #:target-type shepherd-root-service-type))))
 
   (mlet* %store-monad ((live-services (running-services eval)))
-    (let ((to-unload to-restart
-                     (shepherd-service-upgrade live-services target-services)))
-      (let* ((to-unload  (map live-service-canonical-name to-unload))
-             (to-restart (map shepherd-service-canonical-name to-restart))
-             (running    (map live-service-canonical-name
-                              (filter live-service-running live-services)))
-             (to-start   (lset-difference eqv?
-                                          (map shepherd-service-canonical-name
-                                               target-services)
-                                          running))
-             (service-files (map shepherd-service-file target-services)))
-        (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
-                  (primitive-load #$(upgrade-services-program service-files
-                                                              to-start
-                                                              to-unload
-                                                              to-restart))))))))
+    (let* ((to-unload to-restart
+                      (shepherd-service-upgrade live-services target-services))
+           (to-unload  (map live-service-canonical-name to-unload))
+           (to-restart (map shepherd-service-canonical-name to-restart))
+           (running    (map live-service-canonical-name
+                            (filter live-service-running live-services)))
+           (to-start   (lset-difference eqv?
+                                        (map shepherd-service-canonical-name
+                                             target-services)
+                                        running))
+           (service-files (map shepherd-service-file target-services)))
+      (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
+                (primitive-load #$(upgrade-services-program service-files
+                                                            to-start
+                                                            to-unload
+                                                            to-restart)))))))
 
 
 ;;;
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
index d7c71ef705..e4fe511382 100644
--- a/guix/scripts/time-machine.scm
+++ b/guix/scripts/time-machine.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2019 Konrad Hinsen <konrad.hinsen@fastmail.net>
 ;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,13 +20,15 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix scripts time-machine)
+  #:use-module (guix channels)
+  #:use-module (guix diagnostics)
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix inferior)
   #:use-module (guix store)
   #:use-module (guix status)
   #:use-module ((guix git)
-                #:select (with-git-error-handling))
+                #:select (update-cached-checkout with-git-error-handling))
   #:use-module ((guix utils)
                 #:select (%current-system))
   #:use-module ((guix scripts pull)
@@ -38,9 +41,17 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-71)
   #:export (guix-time-machine))
 
+;;; The required inferiors mechanism relied on by 'guix time-machine' was
+;;; firmed up in v1.0.0; it is the oldest, safest commit that can be travelled
+;;; to.
+(define %oldest-possible-commit
+  "6298c3ffd9654d3231a6f25390b056483e8f407c") ;v1.0.0
+
 
 ;;;
 ;;; Command-line options.
@@ -81,7 +92,7 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
                                (alist-delete 'repository-url result))))
          (option '("commit") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'ref `(commit . ,arg) result)))
+                   (alist-cons 'ref `(tag-or-commit . ,arg) result)))
          (option '("branch") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'ref `(branch . ,arg) result)))
@@ -140,8 +151,27 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
      (let* ((opts         (parse-args args))
             (channels     (channel-list opts))
             (command-line (assoc-ref opts 'exec))
+            (ref          (assoc-ref opts 'ref))
             (substitutes?  (assoc-ref opts 'substitutes?))
             (authenticate? (assoc-ref opts 'authenticate-channels?)))
+
+       (define (validate-guix-channel channels)
+         "Finds the Guix channel among CHANNELS, and validates that REF as
+captured from the closure, a git reference specification such as a commit hash
+or tag associated to CHANNEL, is valid and new enough to satisfy the 'guix
+time-machine' requirements.  A `formatted-message' condition is raised
+otherwise."
+         (let* ((guix-channel (find guix-channel? channels))
+                (checkout commit relation (update-cached-checkout
+                                           (channel-url guix-channel)
+                                           #:ref (or ref '())
+                                           #:starting-commit
+                                           %oldest-possible-commit)))
+           (unless (memq relation '(ancestor self))
+             (raise (formatted-message
+                     (G_ "cannot travel past commit `~a' from May 1st, 2019")
+                     (string-take %oldest-possible-commit 12))))))
+
        (when command-line
          (let* ((directory
                  (with-store store
@@ -153,6 +183,8 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
                                                          #:dry-run? #f)
                        (set-build-options-from-command-line store opts)
                        (cached-channel-instance store channels
-                                                #:authenticate? authenticate?)))))
+                                                #:authenticate? authenticate?
+                                                #:validate-channels
+                                                validate-guix-channel)))))
                 (executable (string-append directory "/bin/guix")))
            (apply execl (cons* executable executable command-line))))))))