From 9c70c460a05b2bc60f3f3602f0a2dba0f79ce86c Mon Sep 17 00:00:00 2001
From: "Jakob L. Kreuze" <zerodaysfordays@sdf.lonestar.org>
Date: Thu, 15 Aug 2019 04:05:57 -0400
Subject: 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.
---
 gnu/machine.scm | 27 ++++++++++++++++++++++++++-
 1 file changed, 26 insertions(+), 1 deletion(-)

(limited to 'gnu/machine.scm')

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 @@ (define-module (gnu machine)
   #: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 @@ (define-module (gnu machine)
             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 @@ (define-record-type* <environment-type> environment-type
   ;; 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 @@ (define (deploy-machine machine)
 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))
-- 
cgit v1.2.3