X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/462ad9f56b9665b8d22960acee73ad91f1052c9c..refs/heads/wip-bees:/gnu/machine.scm

diff --git a/gnu/machine.scm b/gnu/machine.scm
index 30ae97f6ec..667a988f99 100644
--- a/gnu/machine.scm
+++ b/gnu/machine.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 David Thompson <davet@gnu.org>
-;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,7 +23,8 @@
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix store)
-  #:use-module ((guix utils) #:select (source-properties->location))
+  #:use-module ((guix diagnostics) #:select (source-properties->location))
+  #:use-module (srfi srfi-35)
   #:export (environment-type
             environment-type?
             environment-type-name
@@ -32,7 +33,6 @@
 
             machine
             machine?
-            this-machine
 
             machine-operating-system
             machine-environment
@@ -40,7 +40,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 +72,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
@@ -81,15 +88,18 @@
 ;;; Declarations for machines in a deployment.
 ;;;
 
-(define-record-type* <machine> machine
-  make-machine
+(define-record-type* <machine> machine make-machine
   machine?
-  this-machine
-  (operating-system machine-operating-system) ; <operating-system>
+  (operating-system %machine-operating-system); <operating-system>
   (environment      machine-environment)      ; symbol
   (configuration    machine-configuration     ; configuration object
                     (default #f)))            ; specific to environment
 
+(define (machine-operating-system machine)
+  "Return the operating system of MACHINE."
+  (operating-system-with-provenance
+   (%machine-operating-system machine)))
+
 (define (machine-display-name machine)
   "Return the host-name identifying MACHINE."
   (operating-system-host-name (machine-operating-system machine)))
@@ -105,3 +115,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))