summaryrefslogtreecommitdiff
path: root/gnu/machine.scm
diff options
context:
space:
mode:
authorJakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>2019-08-15 04:05:57 -0400
committerChristopher Lemmer Webber <cwebber@dustycloud.org>2019-08-15 07:43:09 -0400
commit9c70c460a05b2bc60f3f3602f0a2dba0f79ce86c (patch)
tree5b55aca91aba654177e117e61020b68236b8dc58 /gnu/machine.scm
parent5ea7537b9a650cfa525401c19879080a9cf42e13 (diff)
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.
Diffstat (limited to 'gnu/machine.scm')
-rw-r--r--gnu/machine.scm27
1 files changed, 26 insertions, 1 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))