GNU bug report logs - #36845
[PATCH] machine: Implement 'roll-back-machine'.

Please note: This is a static page, with minimal formatting, updated once a day.
Click here to see this page with the latest information and nicer formatting.

Package: guix-patches; Reported by: zerodaysfordays@HIDDEN (Jakob L. Kreuze); Keywords: patch; dated Mon, 29 Jul 2019 22:41:02 UTC; Maintainer for guix-patches is guix-patches@HIDDEN.

Message received at submit <at> debbugs.gnu.org:


Received: (at submit) by debbugs.gnu.org; 29 Jul 2019 22:40:13 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Mon Jul 29 18:40:13 2019
Received: from localhost ([127.0.0.1]:49273 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1hsEJO-0000Ga-G7
	for submit <at> debbugs.gnu.org; Mon, 29 Jul 2019 18:40:10 -0400
Received: from lists.gnu.org ([209.51.188.17]:56095)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hsEJM-0000GT-Jy
 for submit <at> debbugs.gnu.org; Mon, 29 Jul 2019 18:40:09 -0400
Received: from eggs.gnu.org ([2001:470:142:3::10]:42415)
 by lists.gnu.org with esmtp (Exim 4.86_2)
 (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hsEJK-0004ek-UM
 for guix-patches@HIDDEN; Mon, 29 Jul 2019 18:40:08 -0400
X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org
X-Spam-Level: 
X-Spam-Status: No, score=0.8 required=5.0 tests=BAYES_50,RCVD_IN_DNSWL_NONE,
 URIBL_BLOCKED autolearn=disabled version=3.3.2
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hsEJJ-00060L-B2
 for guix-patches@HIDDEN; Mon, 29 Jul 2019 18:40:06 -0400
Received: from mx.sdf.org ([205.166.94.20]:51420)
 by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32)
 (Exim 4.71) (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hsEJI-000601-VH
 for guix-patches@HIDDEN; Mon, 29 Jul 2019 18:40:05 -0400
Received: from Epsilon (pool-173-76-53-40.bstnma.fios.verizon.net
 [173.76.53.40]) (authenticated (0 bits))
 by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x6TMe2kL026764
 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO)
 for <guix-patches@HIDDEN>; Mon, 29 Jul 2019 22:40:03 GMT
From: zerodaysfordays@HIDDEN (Jakob L. Kreuze)
To: guix-patches@HIDDEN
Subject: [PATCH] machine: Implement 'roll-back-machine'.
Date: Mon, 29 Jul 2019 18:37:14 -0400
Message-ID: <87pnlsii1x.fsf@HIDDEN>
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux)
MIME-Version: 1.0
Content-Type: multipart/signed; boundary="=-=-=";
 micalg=pgp-sha256; protocol="application/pgp-signature"
X-detected-operating-system: by eggs.gnu.org: Genre and OS details not
 recognized.
X-Received-From: 205.166.94.20
X-Spam-Score: -2.3 (--)
X-Debbugs-Envelope-To: submit
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -3.3 (---)

--=-=-=
Content-Type: text/plain
Content-Transfer-Encoding: quoted-printable

* 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.
=2D--
 gnu/machine.scm         | 27 ++++++++++++++-
 gnu/machine/ssh.scm     | 75 +++++++++++++++++++++++++++++++++++++++--
 guix/remote.scm         |  1 +
 guix/scripts/deploy.scm | 17 ++++++++--
 4 files changed, 114 insertions(+), 6 deletions(-)

diff --git a/gnu/machine.scm b/gnu/machine.scm
index 0b79402b0a..a143fd190a 100644
=2D-- 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
=20
             deploy-machine
=2D            machine-remote-eval))
+            roll-back-machine
+            machine-remote-eval
+
+            &deploy-error
+            deploy-error?
+            deploy-error-should-roll-back
+            deploy-error-captured-args))
=20
 ;;; 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
=20
   ;; 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 generat=
ion."
   (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 switc=
hing
+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))
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 552eafa9de..b96e71ddce 100644
=2D-- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,6 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
=20
 (define-module (gnu machine ssh)
+  #:use-module (gnu bootloader)
   #:use-module (gnu machine)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu system)
@@ -30,8 +31,10 @@
   #:use-module (guix ssh)
   #:use-module (guix store)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (managed-host-environment-type
=20
@@ -161,6 +164,18 @@ of MACHINE's system profile, ordered from most recent =
to oldest."
                            (boot-parameters-kernel-arguments params))))))))
           generations))))
=20
+(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, wi=
th
+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)
   "Internal implementation of 'deploy-machine' for MACHINE instances with =
an
 environment type of 'managed-host."
@@ -172,9 +187,62 @@ environment type of 'managed-host."
            (bootloader-configuration (operating-system-bootloader os))
            (bootcfg (operating-system-bootcfg os menu-entries)))
       (mbegin %store-monad
=2D        (switch-to-system eval os)
=2D        (upgrade-shepherd-services eval os)
=2D        (install-bootloader eval bootloader-configuration bootcfg)))))
+        (with-roll-back #f
+          (switch-to-system eval os))
+        (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 wi=
th
+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-spec->number %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)))
+                       (eval -> (cut machine-remote-eval machine <>))
+                       (remote-result (machine-remote-eval machine
+                                                           remote-exp)))
+    (when (eqv? 'error remote-result)
+      (raise roll-back-failure))))
=20
 
 ;;;
@@ -185,6 +253,7 @@ environment type of 'managed-host."
   (environment-type
    (machine-remote-eval managed-host-remote-eval)
    (deploy-machine      deploy-managed-host)
+   (roll-back-machine   roll-back-managed-host)
    (name                'managed-host-environment-type)
    (description         "Provisioning for machines that are accessible ove=
r SSH
 and have a known host-name. This entails little more than maintaining an S=
SH
diff --git a/guix/remote.scm b/guix/remote.scm
index 5fecd954e9..853029c54f 100644
=2D-- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -24,6 +24,7 @@
   #:use-module (guix monads)
   #:use-module (guix modules)
   #:use-module (guix derivations)
+  #:use-module (guix utils)
   #:use-module (ssh popen)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 52bba3f3bf..8eeb9ae7a1 100644
=2D-- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -27,6 +27,8 @@
   #:use-module (guix grafts)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:export (guix-deploy))
=20
@@ -87,8 +89,19 @@ Perform the deployment specified by FILE.\n"))
     (with-store store
       (set-build-options-from-command-line store opts)
       (for-each (lambda (machine)
=2D                  (info (G_ "deploying to ~a...") (machine-display-name =
machine))
+                  (info (G_ "deploying to ~a...~%")
+                        (machine-display-name machine))
                   (parameterize ((%current-system (assq-ref opts 'system))
                                  (%graft? (assq-ref opts 'graft?)))
=2D                    (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))))
=2D-=20
2.22.0


--=-=-=
Content-Type: application/pgp-signature; name="signature.asc"

-----BEGIN PGP SIGNATURE-----

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl0/dRoACgkQ9Qb9Fp2P
2VojNQ/+Kpo57KyikEbHdQRe8m3P1l80sOzfiOz1h0SxFCyFJ53q8s9XKUnWVGk4
8zaeUYW3/ZYzBU1yYqZQ5A2OqjWvQrUCHGWmaH2T5sUIYkrQWypHj5pghUwmus9z
6h4yW/f9QbbezXnJglQybhIfjD1hw4W+Z9j+F9a/2hVJS1c9ErIY1o4rKo+bl+tu
16TfTbt9ynC0CezWgYnItgvIdfW2fxYbGGVwo0NPicBQ4rZOVKh1pUkMJDmozDoh
jcp5rDN8V5mle0OfCj5qw4LKdCubVngMinJUl/wa/jaX5Tg4QxtYlEnh0En2rCbb
UlesnvXxCxmmBynry0PwxAd/w31nT4dM2k3b7avVlxkIdNKLiJsnofl2ashCasa7
JNB8VaxIVRQrICl3ubUoFXkfLAH7onK9Gj9tDLjam2a3t7sPm/j/v2NPwI+G5U7h
A6naOiQcder9Wiv3moP9Y2x7Qi+9i284YwylX+Lh8bQ4Htsc5B3gf0SxGrlm4xX9
wWO2gDIgy7uxy3R1oGe63mIh1HGQ5rgl80yZ3POyZdqwquuIQwisBYWMChA0IH4p
oL575TGVYki6hEx5GuhItLqaPqWDkQRd7pbKQxT8+I0RY2b0hO9D8QbvHSNGixPd
0y8FQYtYYT5v7m8RNXl8sTsjt2MsX1Qt3M2pdixARgcnCF78Ms0=
=Ptwh
-----END PGP SIGNATURE-----
--=-=-=--




Acknowledgement sent to zerodaysfordays@HIDDEN (Jakob L. Kreuze):
New bug report received and forwarded. Copy sent to guix-patches@HIDDEN. Full text available.
Report forwarded to guix-patches@HIDDEN:
bug#36845; Package guix-patches. Full text available.
Please note: This is a static page, with minimal formatting, updated once a day.
Click here to see this page with the latest information and nicer formatting.
Last modified: Mon, 29 Jul 2019 22:45:01 UTC

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997 nCipher Corporation Ltd, 1994-97 Ian Jackson.