diff options
author | Liliana Marie Prikler <liliana.prikler@gmail.com> | 2023-08-26 07:08:03 +0200 |
---|---|---|
committer | Liliana Marie Prikler <liliana.prikler@gmail.com> | 2023-08-26 07:08:03 +0200 |
commit | 9d074e16c7a9879d67c348c7b2d70b725adfbdfa (patch) | |
tree | c4c8dc52508717b3b7aa7c988924a03aa6eb83d8 /guix/scripts/time-machine.scm | |
parent | ca7e310f7ac32354b2e693e9a0f783320952a8fc (diff) | |
parent | eeb71d778f149834015858467fbeeb1276d96d1d (diff) |
Merge branch 'master' into emacs-team
Diffstat (limited to 'guix/scripts/time-machine.scm')
-rw-r--r-- | guix/scripts/time-machine.scm | 46 |
1 files changed, 42 insertions, 4 deletions
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index d7c71ef705..87000d82ec 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Konrad Hinsen <konrad.hinsen@fastmail.net> -;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020, 2021, 2023 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. @@ -52,6 +63,9 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) (display (G_ " -C, --channels=FILE deploy the channels defined in FILE")) (display (G_ " + -q, --no-channel-files + inhibit loading of user and system 'channels.scm'")) + (display (G_ " --url=URL use the Git repository at URL")) (display (G_ " --commit=COMMIT use the specified COMMIT")) @@ -75,13 +89,16 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) (cons* (option '(#\C "channels") #t #f (lambda (opt name arg result) (alist-cons 'channel-file arg result))) + (option '(#\q "no-channel-files") #f #f + (lambda (opt name arg result) + (alist-cons 'ignore-channel-files? #t result))) (option '("url") #t #f (lambda (opt name arg result) (alist-cons 'repository-url arg (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 +157,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 +189,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)))))))) |