diff options
| -rw-r--r-- | doc/guix.texi | 10 | ||||
| -rw-r--r-- | gnu/machine/ssh.scm | 32 | ||||
| -rw-r--r-- | gnu/services.scm | 26 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 21 |
4 files changed, 69 insertions, 20 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index e2b304ff63..ca96ecc298 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -29033,6 +29033,16 @@ When @code{host-key} is @code{#f}, the server is authenticated against the @file{~/.ssh/known_hosts} file, just like the OpenSSH @command{ssh} client does. +@item @code{allow-downgrades?} (default: @code{#f}) +Whether to allow potential downgrades. + +Like @command{guix system reconfigure}, @command{guix deploy} compares +the channel commits currently deployed on the remote host (as returned +by @command{guix system describe}) to those currently in use (as +returned by @command{guix describe}) to determine whether commits +currently in use are descendants of those deployed. When this is not +the case and @code{allow-downgrades?} is false, it raises an error. +This ensures you do not accidentally downgrade remote machines. @end table @end deftp diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 641e871861..4e31baa4b9 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -24,6 +24,7 @@ #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) + #:use-module ((gnu services) #:select (sexp->system-provenance)) #:use-module (guix diagnostics) #:use-module (guix gexp) #:use-module (guix i18n) @@ -55,6 +56,7 @@ machine-ssh-configuration-host-name machine-ssh-configuration-build-locally? machine-ssh-configuration-authorize? + machine-ssh-configuration-allow-downgrades? machine-ssh-configuration-port machine-ssh-configuration-user machine-ssh-configuration-host-key @@ -83,6 +85,8 @@ (default #t)) (authorize? machine-ssh-configuration-authorize? ; boolean (default #t)) + (allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean + (default #f)) (port machine-ssh-configuration-port ; integer (default 22)) (user machine-ssh-configuration-user ; string @@ -271,6 +275,27 @@ not available in the initrd." (map missing-modules file-systems)) +(define* (machine-check-forward-update machine) + "Check whether we are making a forward update for MACHINE. Depending on its +'allow-upgrades?' field, raise an error or display a warning if we are +potentially downgrading it." + (define config + (machine-configuration machine)) + + (define validate-reconfigure + (if (machine-ssh-configuration-allow-downgrades? config) + warn-about-backward-reconfigure + ensure-forward-reconfigure)) + + (remote-let ((provenance #~(call-with-input-file + "/run/current-system/provenance" + read))) + (define channels + (sexp->system-provenance provenance)) + + (check-forward-update validate-reconfigure + #:current-channels channels))) + (define (machine-check-building-for-appropriate-system machine) "Raise a '&message' error condition if MACHINE is configured to be built locally and the 'system' field does not match the '%current-system' reported @@ -289,7 +314,8 @@ by MACHINE." 'system' declaration would fail." (define assertions (append (machine-check-file-system-availability machine) - (machine-check-initrd-modules machine))) + (machine-check-initrd-modules machine) + (list (machine-check-forward-update machine)))) (define aggregate-exp ;; Gather all the expressions so that a single round-trip is enough to @@ -491,3 +517,7 @@ connection to the host."))) for environment of type '~a'") config environment))))) + +;; Local Variables: +;; eval: (put 'remote-let 'scheme-indent-function 1) +;; End: diff --git a/gnu/services.scm b/gnu/services.scm index 399a432e3f..11ba21e824 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -89,6 +89,7 @@ system-service-type provenance-service-type + sexp->system-provenance system-provenance boot-service-type cleanup-service-type @@ -488,6 +489,19 @@ channels in use and CONFIG-FILE, if it is true." itself: the channels used when building the system, and its configuration file, when available."))) +(define (sexp->system-provenance sexp) + "Parse SEXP, an s-expression read from /run/current-system/provenance or +similar, and return two values: the list of channels listed therein, and the +OS configuration file or #f." + (match sexp + (('provenance ('version 0) + ('channels channels ...) + ('configuration-file config-file)) + (values (map sexp->channel channels) + config-file)) + (_ + (values '() #f)))) + (define (system-provenance system) "Given SYSTEM, the file name of a system generation, return two values: the list of channels SYSTEM is built from, and its configuration file. If that @@ -495,15 +509,9 @@ information is missing, return the empty list (for channels) and possibly #false (for the configuration file)." (catch 'system-error (lambda () - (match (call-with-input-file (string-append system "/provenance") - read) - (('provenance ('version 0) - ('channels channels ...) - ('configuration-file config-file)) - (values (map sexp->channel channels) - config-file)) - (_ - (values '() #f)))) + (sexp->system-provenance + (call-with-input-file (string-append system "/provenance") + read))) (lambda _ (values '() #f)))) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index a2570839a8..45bb1d5d3b 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -339,24 +339,25 @@ to commits of channels in NEW." old)) (define* (check-forward-update #:optional - (validate-reconfigure ensure-forward-reconfigure)) + (validate-reconfigure + ensure-forward-reconfigure) + #:key + (current-channels + (system-provenance "/run/current-system"))) "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the -currently-deployed commit (as returned by 'guix system describe') and the -target commit (as returned by 'guix describe')." - ;; TODO: Make that functionality available to 'guix deploy'. +currently-deployed commit (from CURRENT-CHANNELS, which is as returned by +'guix system describe' by default) and the target commit (as returned by 'guix +describe')." (define new (or (and=> (current-profile) profile-channels) '())) - (define old - (system-provenance "/run/current-system")) - - (when (null? old) - (warning (G_ "cannot determine provenance for /run/current-system~%"))) + (when (null? current-channels) + (warning (G_ "cannot determine provenance for current system~%"))) (when (and (null? new) (not (getenv "GUIX_UNINSTALLED"))) (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name)) (for-each (match-lambda ((channel old new relation) (validate-reconfigure channel old new relation))) - (channel-relations old new))) + (channel-relations current-channels new))) |