machine: Implement 'roll-back-machine'.

* gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?)
(deploy-error-should-roll-back)
(deploy-error-captured-args): New variable.
* gnu/machine/ssh.scm (roll-back-managed-host): New variable.
* guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a
deployment fails.
This commit is contained in:
Jakob L. Kreuze 2019-08-15 04:05:57 -04:00 committed by Christopher Lemmer Webber
parent 5ea7537b9a
commit 9c70c460a0
No known key found for this signature in database
GPG key ID: 4BC025925FF8F4D3
3 changed files with 110 additions and 6 deletions

View file

@ -24,6 +24,7 @@ (define-module (gnu machine)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix store) #:use-module (guix store)
#:use-module ((guix utils) #:select (source-properties->location)) #:use-module ((guix utils) #:select (source-properties->location))
#:use-module (srfi srfi-35)
#:export (environment-type #:export (environment-type
environment-type? environment-type?
environment-type-name environment-type-name
@ -40,7 +41,13 @@ (define-module (gnu machine)
machine-display-name machine-display-name
deploy-machine 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: ;;; Commentary:
;;; ;;;
@ -66,6 +73,7 @@ (define-record-type* <environment-type> environment-type
;; of the form '(machine-remote-eval machine exp)'. ;; of the form '(machine-remote-eval machine exp)'.
(machine-remote-eval environment-type-machine-remote-eval) ; procedure (machine-remote-eval environment-type-machine-remote-eval) ; procedure
(deploy-machine environment-type-deploy-machine) ; procedure (deploy-machine environment-type-deploy-machine) ; procedure
(roll-back-machine environment-type-roll-back-machine) ; procedure
;; Metadata. ;; Metadata.
(name environment-type-name) ; symbol (name environment-type-name) ; symbol
@ -105,3 +113,20 @@ (define (deploy-machine machine)
MACHINE, activating it on MACHINE and switching MACHINE to the new generation." MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
(let ((environment (machine-environment machine))) (let ((environment (machine-environment machine)))
((environment-type-deploy-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))

View file

@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu machine ssh) (define-module (gnu machine ssh)
#:use-module (gnu bootloader)
#:use-module (gnu machine) #:use-module (gnu machine)
#:autoload (gnu packages gnupg) (guile-gcrypt) #:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu system) #:use-module (gnu system)
@ -34,6 +35,7 @@ (define-module (gnu machine ssh)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
@ -341,6 +343,18 @@ (define (read-file path)
(boot-parameters-kernel-arguments params)))))))) (boot-parameters-kernel-arguments params))))))))
generations)))) 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) (define (deploy-managed-host machine)
"Internal implementation of 'deploy-machine' for MACHINE instances with an "Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host." environment type of 'managed-host."
@ -353,9 +367,60 @@ (define (deploy-managed-host machine)
(bootloader-configuration (operating-system-bootloader os)) (bootloader-configuration (operating-system-bootloader os))
(bootcfg (operating-system-bootcfg os menu-entries))) (bootcfg (operating-system-bootcfg os menu-entries)))
(mbegin %store-monad (mbegin %store-monad
(switch-to-system eval os) (with-roll-back #f
(upgrade-shepherd-services eval os) (switch-to-system eval os))
(install-bootloader eval bootloader-configuration bootcfg))))) (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 @@ (define managed-host-environment-type
(environment-type (environment-type
(machine-remote-eval managed-host-remote-eval) (machine-remote-eval managed-host-remote-eval)
(deploy-machine deploy-managed-host) (deploy-machine deploy-managed-host)
(roll-back-machine roll-back-managed-host)
(name 'managed-host-environment-type) (name 'managed-host-environment-type)
(description "Provisioning for machines that are accessible over SSH (description "Provisioning for machines that are accessible over SSH
and have a known host-name. This entails little more than maintaining an SSH and have a known host-name. This entails little more than maintaining an SSH

View file

@ -28,6 +28,8 @@ (define-module (guix scripts deploy)
#:use-module (guix grafts) #:use-module (guix grafts)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:export (guix-deploy)) #:export (guix-deploy))
@ -88,7 +90,18 @@ (define (handle-argument arg result)
(with-store store (with-store store
(set-build-options-from-command-line store opts) (set-build-options-from-command-line store opts)
(for-each (lambda (machine) (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?))) (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)))) machines))))