mirror/guix
mirror/guix
1
Fork 0
mirror of https://https.git.savannah.gnu.org/git/guix.git/ synced 2025-07-13 02:20:53 +02:00
Code Releases Activity

machine: Implement 'roll-back-machine'.

Browse source 
* 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
Download patch file Download diff file Expand all files Collapse all files

27
gnu/machine.scm
View file

@ -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))