diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/home.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 31 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 32 | ||||
| -rw-r--r-- | guix/scripts/time-machine.scm | 38 |
5 files changed, 81 insertions, 29 deletions
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)))))))) |