summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/machine.scm27
-rw-r--r--gnu/machine/ssh.scm72
-rw-r--r--guix/scripts/deploy.scm17
3 files changed, 110 insertions, 6 deletions
diff --git a/gnu/machine.scm b/gnu/machine.scm
index 30ae97f6ec..05b03b21d4 100644
--- a/gnu/machine.scm
+++ b/gnu/machine.scm
@@ -24,6 +24,7 @@
#:use-module (guix records)
#:use-module (guix store)
#:use-module ((guix utils) #:select (source-properties->location))
+ #:use-module (srfi srfi-35)
#:export (environment-type
environment-type?
environment-type-name
@@ -40,7 +41,13 @@
machine-display-name
deploy-machine
- machine-remote-eval))
+ roll-back-machine
+ machine-remote-eval
+
+ &deploy-error
+ deploy-error?
+ deploy-error-should-roll-back
+ deploy-error-captured-args))
;;; Commentary:
;;;
@@ -66,6 +73,7 @@
;; of the form '(machine-remote-eval machine exp)'.
(machine-remote-eval environment-type-machine-remote-eval) ; procedure
(deploy-machine environment-type-deploy-machine) ; procedure
+ (roll-back-machine environment-type-roll-back-machine) ; procedure
;; Metadata.
(name environment-type-name) ; symbol
@@ -105,3 +113,20 @@ are built and deployed to MACHINE beforehand."
MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
(let ((environment (machine-environment machine)))
((environment-type-deploy-machine environment) machine)))
+
+(define (roll-back-machine machine)
+ "Monadic procedure rolling back to the previous system generation on
+MACHINE. Return the number of the generation that was current before switching
+and the new generation number."
+ (let ((environment (machine-environment machine)))
+ ((environment-type-roll-back-machine environment) machine)))
+
+
+;;;
+;;; Error types.
+;;;
+
+(define-condition-type &deploy-error &error
+ deploy-error?
+ (should-roll-back deploy-error-should-roll-back)
+ (captured-args deploy-error-captured-args))
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index fb15d39e61..4b5d5fe3a2 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu machine ssh)
+ #:use-module (gnu bootloader)
#:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu system)
@@ -34,6 +35,7 @@
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
@@ -341,6 +343,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
(boot-parameters-kernel-arguments params))))))))
generations))))
+(define-syntax-rule (with-roll-back should-roll-back? mbody ...)
+ "Catch exceptions that arise when binding MBODY, a monadic expression in
+%STORE-MONAD, and collect their arguments in a &deploy-error condition, with
+the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
+ (catch #t
+ (lambda ()
+ mbody ...)
+ (lambda args
+ (raise (condition (&deploy-error
+ (should-roll-back should-roll-back?)
+ (captured-args args)))))))
+
(define (deploy-managed-host machine)
"Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host."
@@ -353,9 +367,60 @@ environment type of 'managed-host."
(bootloader-configuration (operating-system-bootloader os))
(bootcfg (operating-system-bootcfg os menu-entries)))
(mbegin %store-monad
- (switch-to-system eval os)
- (upgrade-shepherd-services eval os)
- (install-bootloader eval bootloader-configuration bootcfg)))))
+ (with-roll-back #f
+ (switch-to-system eval os))
+ (with-roll-back #t
+ (mbegin %store-monad
+ (upgrade-shepherd-services eval os)
+ (install-bootloader eval bootloader-configuration bootcfg)))))))
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-managed-host machine)
+ "Internal implementation of 'roll-back-machine' for MACHINE instances with
+an environment type of 'managed-host."
+ (define remote-exp
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules (source-module-closure '((guix config)
+ (guix profiles)))
+ #~(begin
+ (use-modules (guix config)
+ (guix profiles))
+
+ (define %system-profile
+ (string-append %state-directory "/profiles/system"))
+
+ (define target-generation
+ (relative-generation %system-profile -1))
+
+ (if target-generation
+ (switch-to-generation %system-profile target-generation)
+ 'error)))))
+
+ (define roll-back-failure
+ (condition (&message (message (G_ "could not roll-back machine")))))
+
+ (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
+ (_ -> (if (< (length boot-parameters) 2)
+ (raise roll-back-failure)))
+ (entries -> (map boot-parameters->menu-entry
+ (list (second boot-parameters))))
+ (old-entries -> (map boot-parameters->menu-entry
+ (drop boot-parameters 2)))
+ (bootloader -> (operating-system-bootloader
+ (machine-operating-system machine)))
+ (bootcfg (lower-object
+ ((bootloader-configuration-file-generator
+ (bootloader-configuration-bootloader
+ bootloader))
+ bootloader entries
+ #:old-entries old-entries)))
+ (remote-result (machine-remote-eval machine remote-exp)))
+ (when (eqv? 'error remote-result)
+ (raise roll-back-failure))))
;;;
@@ -366,6 +431,7 @@ environment type of 'managed-host."
(environment-type
(machine-remote-eval managed-host-remote-eval)
(deploy-machine deploy-managed-host)
+ (roll-back-machine roll-back-managed-host)
(name 'managed-host-environment-type)
(description "Provisioning for machines that are accessible over SSH
and have a known host-name. This entails little more than maintaining an SSH
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 81f2b33260..6a67985c8b 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -28,6 +28,8 @@
#:use-module (guix grafts)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:export (guix-deploy))
@@ -88,7 +90,18 @@ Perform the deployment specified by FILE.\n"))
(with-store store
(set-build-options-from-command-line store opts)
(for-each (lambda (machine)
- (info (G_ "deploying to ~a...") (machine-display-name machine))
+ (info (G_ "deploying to ~a...~%")
+ (machine-display-name machine))
(parameterize ((%graft? (assq-ref opts 'graft?)))
- (run-with-store store (deploy-machine machine))))
+ (guard (c ((message-condition? c)
+ (report-error (G_ "failed to deploy ~a: '~a'~%")
+ (machine-display-name machine)
+ (condition-message c)))
+ ((deploy-error? c)
+ (when (deploy-error-should-roll-back c)
+ (info (G_ "rolling back ~a...~%")
+ (machine-display-name machine))
+ (run-with-store store (roll-back-machine machine)))
+ (apply throw (deploy-error-captured-args c))))
+ (run-with-store store (deploy-machine machine)))))
machines))))