GNU bug report logs - #36952
[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 Wed, 7 Aug 2019 12:46:02 UTC; Maintainer for guix-patches is guix-patches@HIDDEN.

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


Received: (at 36952) by debbugs.gnu.org; 8 Aug 2019 20:17:31 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Thu Aug 08 16:17:31 2019
Received: from localhost ([127.0.0.1]:41752 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1hvoqo-0003qq-TO
	for submit <at> debbugs.gnu.org; Thu, 08 Aug 2019 16:17:31 -0400
Received: from ol.sdf.org ([205.166.94.20]:60437 helo=mx.sdf.org)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hvoqn-0003qi-Jl
 for 36952 <at> debbugs.gnu.org; Thu, 08 Aug 2019 16:17:30 -0400
Received: from Upsilon (mobile-107-107-58-85.mycingular.net [107.107.58.85])
 (authenticated (0 bits))
 by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x78KHP67014171
 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO);
 Thu, 8 Aug 2019 20:17:27 GMT
From: zerodaysfordays@HIDDEN (Jakob L. Kreuze)
To: Ricardo Wurmus <rekado@HIDDEN>
Subject: Re: [bug#36952] [PATCH v3] machine: Implement 'roll-back-machine'.
References: <87v9v94067.fsf@HIDDEN> <87v9v8ohvq.fsf@HIDDEN>
 <87v9v8k82l.fsf_-_@HIDDEN> <87v9v8vskt.fsf@HIDDEN>
Date: Thu, 08 Aug 2019 16:17:24 -0400
In-Reply-To: <87v9v8vskt.fsf@HIDDEN> (Ricardo Wurmus's message of "Thu,
 08 Aug 2019 12:50:58 +0200")
Message-ID: <87y303jtt7.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-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 36952
Cc: Christopher Lemmer Webber <cwebber@HIDDEN>, 36952 <at> debbugs.gnu.org
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: -1.0 (-)

--=-=-=
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     | 73 +++++++++++++++++++++++++++++++++++++++--
 guix/remote.scm         |  1 +
 guix/scripts/deploy.scm | 17 ++++++++--
 4 files changed, 112 insertions(+), 6 deletions(-)

diff --git a/gnu/machine.scm b/gnu/machine.scm
index 30ae97f6ec..05b03b21d4 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 ba3e33c922..2cfb3f20f1 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)
@@ -34,8 +35,10 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #: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
@@ -310,6 +313,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."
@@ -322,9 +337,60 @@ 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 %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)))
+                       (remote-result (machine-remote-eval machine remote-=
exp)))
+    (when (eqv? 'error remote-result)
+      (raise roll-back-failure))))
=20
 
 ;;;
@@ -335,6 +401,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 ebc99e52cc..d16e7d7480 100644
=2D-- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -28,6 +28,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
@@ -91,8 +93,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-----

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl1Mg1UACgkQ9Qb9Fp2P
2VqeWQ/7B8s8LgrovGc1eYdICmHziTy8BsiJF5un9sYpGR9H8u6I2ijJSXtOU3oF
xzGE0AGS3YvFVAuKxhQRQYFO//i7EFHHowdUdW64EvZzukbjpVU9lXxXCnYVm+vu
qLWAoYa8q6VhiRAk6L/7VWHibFq2t6u2iX/Yvl1fO0LPxC0SBnLRFRD168M3v44x
KuWZxBpmwlWtisbQ3zrctKUAxUBpIvmJGENTa98o41DaytN7Fa0ijD88Sf5Dv6Gw
y6kjtv86ZaBMzozNr+xjwkeWHxTiEyuxt9BslXPFsQL0Dt7prnihEjO4kqC4vjNu
vvvkD53ab2UmscMp+fBy/k1NEWNuXGvShNqbn39kgP9YX4FYYol/NWpXCpZmB+TS
Oos88HH2SE2vLj3Z0SgPOWTKLHYsMK/CIezvt+L3HlSoy5kc43fhIL595/0lq5Ce
ZLPcGAd+ttRfgVabEd5pS3x3DHpzmkTDed6582zHehws/EngCG5SrIsx6HsZWOGQ
gY9Xw6GzUUG2BG19OSJ5cINusQ19Mw7kkvDee+b89msLp/V5t934LhI4JdzDqn/1
BX7KjdEtO8lERPUJPdpI7KApCVSKvVPLyTqeEWiT/cj5UkM7dpmEgAFozarNZIZN
LIVo3lvAj7tSvI5kFJeYmfi9gSAxBpRaGSKeRnmMrzjlLnDHt/E=
=4a4M
-----END PGP SIGNATURE-----
--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#36952; Package guix-patches. Full text available.

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


Received: (at 36952) by debbugs.gnu.org; 8 Aug 2019 20:16:56 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Thu Aug 08 16:16:56 2019
Received: from localhost ([127.0.0.1]:41748 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1hvoqG-0003pf-Hw
	for submit <at> debbugs.gnu.org; Thu, 08 Aug 2019 16:16:56 -0400
Received: from ol.sdf.org ([205.166.94.20]:60528 helo=mx.sdf.org)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hvoqA-0003pR-8t
 for 36952 <at> debbugs.gnu.org; Thu, 08 Aug 2019 16:16:53 -0400
Received: from Upsilon (mobile-107-107-58-85.mycingular.net [107.107.58.85])
 (authenticated (0 bits))
 by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x78KGcWv028509
 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO);
 Thu, 8 Aug 2019 20:16:47 GMT
From: zerodaysfordays@HIDDEN (Jakob L. Kreuze)
To: Ricardo Wurmus <rekado@HIDDEN>
Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.
References: <87v9v94067.fsf@HIDDEN> <87v9v8ohvq.fsf@HIDDEN>
 <87v9v8k82l.fsf_-_@HIDDEN> <87v9v8vskt.fsf@HIDDEN>
Date: Thu, 08 Aug 2019 16:16:35 -0400
In-Reply-To: <87v9v8vskt.fsf@HIDDEN> (Ricardo Wurmus's message of "Thu,
 08 Aug 2019 12:50:58 +0200")
Message-ID: <8736ibl8f0.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-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 36952
Cc: Christopher Lemmer Webber <cwebber@HIDDEN>, 36952 <at> debbugs.gnu.org
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: -1.0 (-)

--=-=-=
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable

Hi Ricardo,

Ricardo Wurmus <rekado@HIDDEN> writes:

> Can we use =E2=80=9Crelative-generation=E2=80=9D or =E2=80=9Cprevious-gen=
eration-number=E2=80=9D here?
> I think the stringified =E2=80=9C-1=E2=80=9D is kinda ugly, and the =E2=
=80=9C*-spec=E2=80=9D procedure
> only exists to handle user input, which is provided as a string.

Oh yeah, definitely. I used '*-spec' here because I was using 'guix
system' as a model -- didn't know it was meant for handling user input.

> Is it on purpose that you aren=E2=80=99t using the previously defined =E2=
=80=9Ceval=E2=80=9D
> here?

Whoops! Unused variable, nice catch!

Thanks for the review!

Regards,
Jakob

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

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

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl1MgyYACgkQ9Qb9Fp2P
2VoWXQ/8CJlZvp/+Ve8hhYmibgzwwNrvB3OgAWXN1iedFYMztGIXZdCS8s777oUR
IxGsFVV/b2jiENT14oi5z3/Q0QY2phQkBxI28GnghpNI3fuz3a+k8UuueS4KWshJ
QJCEPgicVKft33TIf62yRSaincFpdoOOSt+PCzs8al9Bzim1X41kumntX1wkhzqG
8pcr+zjUPuAewHAEUhn5eiKAGo+psXMtDX862w8gahi54Do7ehdcJdZ181k5Rjsj
1lIHrz62cj5sDYTkH0cDl0R1910UUWmkYpFIb/1O4kB9bNou27VBhGZVP7kew9Wf
CaBUwGf1Y+D+JPEsGuxBrw+EsKpiWEF64tssTmaOi6rrCFiGC11BzSBofnjLa+Ll
XZIf0NMpiPLPQngl8VaBDz/iIjWOBBOx3wbHGVccxhxSE/Npdxfb3U7MamGTbpce
8mNdB3htvhG0+ViIUmtMgqG2p+xPkRVcSufmrvWfQ5ZjQLKfCwcMCR/9CWD4LTxF
NkidWf7X+48y+O2hcb8VRrx8Vzf2ouJlAfI5nK+YhusnqqcyLKhifN+5km5Ea5zm
ujzSNf4vTEqJqs37NIM3ISQFwa/Mxfun3gUrfdUEgtbCPqglgIDwJP9pxWVZVPAo
xWrLFqTZt2NpKf7VVSbUj9M+rBq4HMfVU0e/BA4iFCnmyYd6rbU=
=nRgv
-----END PGP SIGNATURE-----
--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#36952; Package guix-patches. Full text available.

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


Received: (at 36952) by debbugs.gnu.org; 8 Aug 2019 10:51:17 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Thu Aug 08 06:51:17 2019
Received: from localhost ([127.0.0.1]:39976 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1hvg0r-0005Ae-IP
	for submit <at> debbugs.gnu.org; Thu, 08 Aug 2019 06:51:17 -0400
Received: from sender-of-o51.zoho.com ([135.84.80.216]:21233)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <rekado@HIDDEN>) id 1hvg0l-0005AS-Ey
 for 36952 <at> debbugs.gnu.org; Thu, 08 Aug 2019 06:51:13 -0400
ARC-Seal: i=1; a=rsa-sha256; t=1565261467; cv=none; d=zoho.com; s=zohoarc; 
 b=cxp8z0F+s3yNugtokB0Kiz2vMqL1SWXJQXEiYLyIui3oxPHalJ00sEQo6txSVcvuzNojMsH9B3wj9gsU/HXDLcVYIG4APjpf0lXQQBMqGG85A/TrmrK3/MDMAzX/j0BsUzRDbvvlKTI1sQ6w9gztWd645NZNVFwVtf27AzuAa84=
ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zoho.com;
 s=zohoarc; t=1565261467;
 h=Content-Type:Content-Transfer-Encoding:Cc:Date:From:In-Reply-To:MIME-Version:Message-ID:References:Subject:To:ARC-Authentication-Results;
 bh=wUvYAitayZ+dFthO57wm3YfhFnJfYne1iEWJ/x3SR7c=; 
 b=dYbWIDNd7up77/6WSqHC0WIav2N8llUAqzJOODDdKxCqjBLLTKKfUmr9K64s4TRCHFiDG3LC56xII2jxMr+4uRk9ZehSyCt37MPPkQQGGtUCD42nkZa6bgL0rxGbfzfXchtoyeAUiCYKEBg1kRD1WFWCu+J2r1cA08kXMUsI5rQ=
ARC-Authentication-Results: i=1; mx.zoho.com; dkim=pass  header.i=elephly.net;
 spf=pass  smtp.mailfrom=rekado@HIDDEN;
 dmarc=pass header.from=<rekado@HIDDEN> header.from=<rekado@HIDDEN>
DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; t=1565261467; 
 s=zoho; d=elephly.net; i=rekado@HIDDEN;
 h=References:From:To:Cc:Subject:In-reply-to:Date:Message-ID:MIME-Version:Content-Type:Content-Transfer-Encoding;
 l=1753; bh=wUvYAitayZ+dFthO57wm3YfhFnJfYne1iEWJ/x3SR7c=;
 b=DpjTvTS5lZeBgOjHBUWHClFeX6Ox2h26veyIb1TqxOLT/rBcIhmOm5mzDBv2Y0CL
 bkMQ4tv9eTf3IfeCA3Zdtl+2z5vI1gYU+9JdymhsdTXGg9+ZDwQgoscfSGY3daPst2U
 k1ce+trBhT2Fw5bm9GWt2J5NVaYKwDy82N+UPnRo=
Received: from localhost (141.80.247.250 [141.80.247.250]) by mx.zohomail.com
 with SMTPS id 1565261462659883.2608500337208;
 Thu, 8 Aug 2019 03:51:02 -0700 (PDT)
References: <87v9v94067.fsf@HIDDEN> <87v9v8ohvq.fsf@HIDDEN>
 <87v9v8k82l.fsf_-_@HIDDEN>
User-agent: mu4e 1.2.0; emacs 26.2
From: Ricardo Wurmus <rekado@HIDDEN>
To: Jakob L. Kreuze <zerodaysfordays@HIDDEN>
Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.
In-reply-to: <87v9v8k82l.fsf_-_@HIDDEN>
X-URL: https://elephly.net
X-PGP-Key: https://elephly.net/rekado.pubkey
X-PGP-Fingerprint: BCA6 89B6 3655 3801 C3C6  2150 197A 5888 235F ACAC
Date: Thu, 08 Aug 2019 12:50:58 +0200
Message-ID: <87v9v8vskt.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
X-ZohoMailClient: External
X-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 36952
Cc: Christopher Lemmer Webber <cwebber@HIDDEN>, 36952 <at> debbugs.gnu.org
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: -1.0 (-)


Hi Jakob,

> +(define (roll-back-managed-host machine)
> +  "Internal implementation of 'roll-back-machine' for MACHINE instances =
with
> +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"))

Can we use =E2=80=9Crelative-generation=E2=80=9D or =E2=80=9Cprevious-gener=
ation-number=E2=80=9D here?
I think the stringified =E2=80=9C-1=E2=80=9D is kinda ugly, and the =E2=80=
=9C*-spec=E2=80=9D procedure
only exists to handle user input, which is provided as a string.

> +  (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-generat=
or
> +                                   (bootloader-configuration-bootloader
> +                                    bootloader))
> +                                  bootloader entries
> +                                  #:old-entries old-entries)))
> +                       (eval -> (cut machine-remote-eval machine <>))
> +                       (remote-result (machine-remote-eval machine
> +
> remote-exp)))

Is it on purpose that you aren=E2=80=99t using the previously defined =E2=
=80=9Ceval=E2=80=9D
here?

--
Ricardo





Information forwarded to guix-patches@HIDDEN:
bug#36952; Package guix-patches. Full text available.

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


Received: (at 36952) by debbugs.gnu.org; 7 Aug 2019 22:33:25 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Wed Aug 07 18:33:25 2019
Received: from localhost ([127.0.0.1]:39631 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1hvUUn-0004sS-Ak
	for submit <at> debbugs.gnu.org; Wed, 07 Aug 2019 18:33:25 -0400
Received: from dustycloud.org ([50.116.34.160]:57674)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <cwebber@HIDDEN>) id 1hvUUl-0004sK-NK
 for 36952 <at> debbugs.gnu.org; Wed, 07 Aug 2019 18:33:24 -0400
Received: from twig (localhost [127.0.0.1])
 by dustycloud.org (Postfix) with ESMTPS id 3869D26618;
 Wed,  7 Aug 2019 18:33:23 -0400 (EDT)
References: <87v9v94067.fsf@HIDDEN> <87v9v8ohvq.fsf@HIDDEN>
 <87v9v8k82l.fsf_-_@HIDDEN>
User-agent: mu4e 1.2.0; emacs 26.2
From: Christopher Lemmer Webber <cwebber@HIDDEN>
To: "Jakob L. Kreuze" <zerodaysfordays@HIDDEN>,
 "David Thompson" <dthompson2@HIDDEN>
Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.
In-reply-to: <87v9v8k82l.fsf_-_@HIDDEN>
Date: Wed, 07 Aug 2019 18:33:22 -0400
Message-ID: <87r25wobbh.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 36952
Cc: 36952 <at> debbugs.gnu.org
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: -1.0 (-)

Thanks.  I'm going to specifically loop in Dave...

Dave, mind peering over this before I merge it?

Jakob L. Kreuze writes:

> * 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 ++++++++++++++-
>  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 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))
> diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
> index 274d56db26..ae312597dd 100644
> --- 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/>.
>  
>  (define-module (gnu machine ssh)
> +  #:use-module (gnu bootloader)
>    #:use-module (gnu machine)
>    #:autoload   (gnu packages gnupg) (guile-gcrypt)
>    #:use-module (gnu system)
> @@ -34,8 +35,10 @@
>    #:use-module (guix store)
>    #:use-module (guix utils)
>    #: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
>  
> @@ -304,6 +307,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
>                             (boot-parameters-kernel-arguments params))))))))
>            generations))))
>  
> +(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, with
> +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."
> @@ -316,9 +331,62 @@ environment type of 'managed-host."
>             (bootloader-configuration (operating-system-bootloader os))
>             (bootcfg (operating-system-bootcfg os menu-entries)))
>        (mbegin %store-monad
> -        (switch-to-system eval os)
> -        (upgrade-shepherd-services eval os)
> -        (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 with
> +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))))
>  
>  
>  ;;;
> @@ -329,6 +397,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 over SSH
>  and have a known host-name. This entails little more than maintaining an SSH
> diff --git a/guix/remote.scm b/guix/remote.scm
> index 5fecd954e9..853029c54f 100644
> --- 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 ebc99e52cc..d16e7d7480 100644
> --- a/guix/scripts/deploy.scm
> +++ b/guix/scripts/deploy.scm
> @@ -28,6 +28,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))
>  
> @@ -91,8 +93,19 @@ Perform the deployment specified by FILE.\n"))
>      (with-store store
>        (set-build-options-from-command-line store opts)
>        (for-each (lambda (machine)
> -                  (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?)))
> -                    (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))))





Information forwarded to guix-patches@HIDDEN:
bug#36952; Package guix-patches. Full text available.

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


Received: (at 36952) by debbugs.gnu.org; 7 Aug 2019 21:00:23 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Wed Aug 07 17:00:23 2019
Received: from localhost ([127.0.0.1]:39559 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1hvT2l-0008Kr-55
	for submit <at> debbugs.gnu.org; Wed, 07 Aug 2019 17:00:23 -0400
Received: from mx.sdf.org ([205.166.94.20]:54403)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hvT2j-0008Kh-Ho
 for 36952 <at> debbugs.gnu.org; Wed, 07 Aug 2019 17:00:22 -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 x77L0Hcj026845
 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO);
 Wed, 7 Aug 2019 21:00:19 GMT
From: zerodaysfordays@HIDDEN (Jakob L. Kreuze)
To: Christopher Lemmer Webber <cwebber@HIDDEN>
Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'.
References: <87v9v94067.fsf@HIDDEN> <87v9v8ohvq.fsf@HIDDEN>
Date: Wed, 07 Aug 2019 16:57:06 -0400
In-Reply-To: <87v9v8ohvq.fsf@HIDDEN> (Christopher Lemmer Webber's
 message of "Wed, 07 Aug 2019 16:11:37 -0400")
Message-ID: <87v9v8k82l.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-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: 36952
Cc: 36952 <at> debbugs.gnu.org
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: -1.0 (-)

--=-=-=
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 30ae97f6ec..05b03b21d4 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 274d56db26..ae312597dd 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)
@@ -34,8 +35,10 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #: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
@@ -304,6 +307,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."
@@ -316,9 +331,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
 
 ;;;
@@ -329,6 +397,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 ebc99e52cc..d16e7d7480 100644
=2D-- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -28,6 +28,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
@@ -91,8 +93,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-----

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl1LOyIACgkQ9Qb9Fp2P
2VoCvxAAppGfVYme2uuGk/NXKZP7h3ReraQACGxWwCHrg5oCI8azsR2hAO3+SbHG
bvC96HLWy+87jh5TMmbjwr/QuJIrqwJ2zvX/54CyzCSUFaTVoJ66mqZiKGVUZt28
jehnD+TOUC8jp80ilobZm3PXXqeolQKb//AklEp/yaC6NxeLMtjceotl32w0jTEn
iD9SiJGjgxcbnt8jue+hE5PpEy8f3PkCYcte0oHIutRl7T1AcuSx9xQOJso+MZ0Q
igdZDRpYX8tsOLYhDxnVkWmWJhBVpXRxLFTo1JNSOrDOUc+sxZrH4PyfjN47iSfi
+2Jl989AwLJxsV5ONBiVtKL7jWjkZBdTxHI3T0Ir6nVPyJJF704acKcLAnWkEj34
+vP0vLWYL7VpMLHdQkEdOxJKJBKBeu25181HdStPOvL7+MbdpYlp8sY39IRlhJ9e
AdqyQ6YtzWC+1rRllYzM2j9rRwZhpqkjAicZe4q79ItgzpbKsKTCdN9L7LJXcdXp
c6WwDKDmJEVzrij+cXizypzBEfD9+WYSobo04Q/B5bjMwe32HXgwvlBlm+kVyj0V
ToirMKShNMQKZFRlAA92N913XpxGvCjmL02tDaQCzPEzCdRl0HS+jRe2xTvS7tC6
tjQxpCGBjvU419S6rWdeUG73zwcDTxbMWgEjsgsfLFMoUPo49x4=
=68+q
-----END PGP SIGNATURE-----
--=-=-=--




Information forwarded to guix-patches@HIDDEN:
bug#36952; Package guix-patches. Full text available.

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


Received: (at 36952) by debbugs.gnu.org; 7 Aug 2019 20:11:40 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Wed Aug 07 16:11:40 2019
Received: from localhost ([127.0.0.1]:39491 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1hvSHb-0004eX-Sh
	for submit <at> debbugs.gnu.org; Wed, 07 Aug 2019 16:11:40 -0400
Received: from dustycloud.org ([50.116.34.160]:56414)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <cwebber@HIDDEN>) id 1hvSHa-0004eN-9p
 for 36952 <at> debbugs.gnu.org; Wed, 07 Aug 2019 16:11:38 -0400
Received: from twig (localhost [127.0.0.1])
 by dustycloud.org (Postfix) with ESMTPS id B990D26618;
 Wed,  7 Aug 2019 16:11:37 -0400 (EDT)
References: <87v9v94067.fsf@HIDDEN>
User-agent: mu4e 1.2.0; emacs 26.2
From: Christopher Lemmer Webber <cwebber@HIDDEN>
To: guix-patches@HIDDEN
Subject: Re: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'.
In-reply-to: <87v9v94067.fsf@HIDDEN>
Date: Wed, 07 Aug 2019 16:11:37 -0400
Message-ID: <87v9v8ohvq.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain
X-Spam-Score: -0.0 (/)
X-Debbugs-Envelope-To: 36952
Cc: 36952 <at> debbugs.gnu.org
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: -1.0 (-)

I don't notice any obvious bugs, but I'm not fully confident in my
ability to catch them here.  Another set of eyes might help.

This doesn't apply on top of current master though; could you rebase?

Jakob L. Kreuze writes:

> * 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 ++++++++++++++-
>  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 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))
> diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
> index 274d56db26..ae312597dd 100644
> --- 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/>.
>  
>  (define-module (gnu machine ssh)
> +  #:use-module (gnu bootloader)
>    #:use-module (gnu machine)
>    #:autoload   (gnu packages gnupg) (guile-gcrypt)
>    #:use-module (gnu system)
> @@ -34,8 +35,10 @@
>    #:use-module (guix store)
>    #:use-module (guix utils)
>    #: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
>  
> @@ -304,6 +307,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
>                             (boot-parameters-kernel-arguments params))))))))
>            generations))))
>  
> +(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, with
> +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."
> @@ -316,9 +331,62 @@ environment type of 'managed-host."
>             (bootloader-configuration (operating-system-bootloader os))
>             (bootcfg (operating-system-bootcfg os menu-entries)))
>        (mbegin %store-monad
> -        (switch-to-system eval os)
> -        (upgrade-shepherd-services eval os)
> -        (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 with
> +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))))
>  
>  
>  ;;;
> @@ -329,6 +397,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 over SSH
>  and have a known host-name. This entails little more than maintaining an SSH
> diff --git a/guix/remote.scm b/guix/remote.scm
> index 0a0bdaf30b..d5738ebbfa 100644
> --- 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 52d5e1e1da..bc1d93a93a 100644
> --- 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))
>  
> @@ -84,7 +86,18 @@ Perform the deployment specified by FILE.\n"))
>      (with-store store
>        (set-build-options-from-command-line store opts)
>        (for-each (lambda (machine)
> -                  (info (G_ "deploying to ~a...") (machine-display-name machine))
> +                  (info (G_ "deploying to ~a...~%")
> +                        (machine-display-name machine))
>                    (parameterize ((%graft? (assq-ref opts 'graft?)))
> -                    (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))))





Information forwarded to guix-patches@HIDDEN:
bug#36952; Package guix-patches. Full text available.

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


Received: (at submit) by debbugs.gnu.org; 7 Aug 2019 20:11:45 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Wed Aug 07 16:11:45 2019
Received: from localhost ([127.0.0.1]:39494 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1hvSHg-0004ep-F0
	for submit <at> debbugs.gnu.org; Wed, 07 Aug 2019 16:11:44 -0400
Received: from lists.gnu.org ([209.51.188.17]:53821)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <cwebber@HIDDEN>) id 1hvSHe-0004ef-0t
 for submit <at> debbugs.gnu.org; Wed, 07 Aug 2019 16:11:42 -0400
Received: from eggs.gnu.org ([2001:470:142:3::10]:58158)
 by lists.gnu.org with esmtp (Exim 4.86_2)
 (envelope-from <cwebber@HIDDEN>) id 1hvSHc-0002rT-CM
 for guix-patches@HIDDEN; Wed, 07 Aug 2019 16:11:41 -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,URIBL_BLOCKED
 autolearn=disabled version=3.3.2
Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
 (envelope-from <cwebber@HIDDEN>) id 1hvSHa-00008r-NY
 for guix-patches@HIDDEN; Wed, 07 Aug 2019 16:11:40 -0400
Received: from dustycloud.org ([50.116.34.160]:44918)
 by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32)
 (Exim 4.71) (envelope-from <cwebber@HIDDEN>)
 id 1hvSHa-00007B-IL
 for guix-patches@HIDDEN; Wed, 07 Aug 2019 16:11:38 -0400
Received: from twig (localhost [127.0.0.1])
 by dustycloud.org (Postfix) with ESMTPS id B990D26618;
 Wed,  7 Aug 2019 16:11:37 -0400 (EDT)
References: <87v9v94067.fsf@HIDDEN>
User-agent: mu4e 1.2.0; emacs 26.2
From: Christopher Lemmer Webber <cwebber@HIDDEN>
To: guix-patches@HIDDEN
Subject: Re: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'.
In-reply-to: <87v9v94067.fsf@HIDDEN>
Date: Wed, 07 Aug 2019 16:11:37 -0400
Message-ID: <87v9v8ohvq.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 50.116.34.160
X-Spam-Score: -1.3 (-)
X-Debbugs-Envelope-To: submit
Cc: 36952 <at> debbugs.gnu.org
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: -2.3 (--)

I don't notice any obvious bugs, but I'm not fully confident in my
ability to catch them here.  Another set of eyes might help.

This doesn't apply on top of current master though; could you rebase?

Jakob L. Kreuze writes:

> * 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 ++++++++++++++-
>  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 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))
> diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
> index 274d56db26..ae312597dd 100644
> --- 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/>.
>  
>  (define-module (gnu machine ssh)
> +  #:use-module (gnu bootloader)
>    #:use-module (gnu machine)
>    #:autoload   (gnu packages gnupg) (guile-gcrypt)
>    #:use-module (gnu system)
> @@ -34,8 +35,10 @@
>    #:use-module (guix store)
>    #:use-module (guix utils)
>    #: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
>  
> @@ -304,6 +307,18 @@ of MACHINE's system profile, ordered from most recent to oldest."
>                             (boot-parameters-kernel-arguments params))))))))
>            generations))))
>  
> +(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, with
> +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."
> @@ -316,9 +331,62 @@ environment type of 'managed-host."
>             (bootloader-configuration (operating-system-bootloader os))
>             (bootcfg (operating-system-bootcfg os menu-entries)))
>        (mbegin %store-monad
> -        (switch-to-system eval os)
> -        (upgrade-shepherd-services eval os)
> -        (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 with
> +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))))
>  
>  
>  ;;;
> @@ -329,6 +397,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 over SSH
>  and have a known host-name. This entails little more than maintaining an SSH
> diff --git a/guix/remote.scm b/guix/remote.scm
> index 0a0bdaf30b..d5738ebbfa 100644
> --- 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 52d5e1e1da..bc1d93a93a 100644
> --- 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))
>  
> @@ -84,7 +86,18 @@ Perform the deployment specified by FILE.\n"))
>      (with-store store
>        (set-build-options-from-command-line store opts)
>        (for-each (lambda (machine)
> -                  (info (G_ "deploying to ~a...") (machine-display-name machine))
> +                  (info (G_ "deploying to ~a...~%")
> +                        (machine-display-name machine))
>                    (parameterize ((%graft? (assq-ref opts 'graft?)))
> -                    (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))))





Information forwarded to guix-patches@HIDDEN:
bug#36952; Package guix-patches. Full text available.

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


Received: (at submit) by debbugs.gnu.org; 7 Aug 2019 12:45:35 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Wed Aug 07 08:45:35 2019
Received: from localhost ([127.0.0.1]:38155 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1hvLJv-0000KN-3A
	for submit <at> debbugs.gnu.org; Wed, 07 Aug 2019 08:45:35 -0400
Received: from lists.gnu.org ([209.51.188.17]:46027)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hvLJq-0000KB-97
 for submit <at> debbugs.gnu.org; Wed, 07 Aug 2019 08:45:33 -0400
Received: from eggs.gnu.org ([2001:470:142:3::10]:47957)
 by lists.gnu.org with esmtp (Exim 4.86_2)
 (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hvLJo-000786-LA
 for guix-patches@HIDDEN; Wed, 07 Aug 2019 08:45:30 -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 1hvLJn-0003N6-1n
 for guix-patches@HIDDEN; Wed, 07 Aug 2019 08:45:28 -0400
Received: from mx.sdf.org ([205.166.94.20]:65431)
 by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32)
 (Exim 4.71) (envelope-from <zerodaysfordays@HIDDEN>)
 id 1hvLJm-0003Lw-N6
 for guix-patches@HIDDEN; Wed, 07 Aug 2019 08:45:26 -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 x77CjKoX027950
 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO)
 for <guix-patches@HIDDEN>; Wed, 7 Aug 2019 12:45:24 GMT
From: zerodaysfordays@HIDDEN (Jakob L. Kreuze)
To: guix-patches@HIDDEN
Subject: [PATCH] machine: Implement 'roll-back-machine'.
Date: Wed, 07 Aug 2019 08:42:08 -0400
Message-ID: <87v9v94067.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 30ae97f6ec..05b03b21d4 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 274d56db26..ae312597dd 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)
@@ -34,8 +35,10 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #: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
@@ -304,6 +307,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."
@@ -316,9 +331,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
 
 ;;;
@@ -329,6 +397,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 0a0bdaf30b..d5738ebbfa 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 52d5e1e1da..bc1d93a93a 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
@@ -84,7 +86,18 @@ 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 ((%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-----

iQIzBAEBCAAdFiEEa1VJLOiXAjQ2BGSm9Qb9Fp2P2VoFAl1KxyEACgkQ9Qb9Fp2P
2Vr6mg/+Pnus0ohWQoPsGNYvabPZodH+d6fuSaVYI3iwdzYRGv9LJKiXJYxukvvK
dsoZajyQ4FltLN9TJHHEPR/grbcXPvl2idLZHRRRUKG9LKum11pzzUyy0lzUYWo1
K3sbND0ACOu5xjT7PMguwB7JFcysaQ7dXF4EUi9jM0FG6xGL2bdip9zRByykzKfw
KoJBKMfETRuzDwBT1t9dUGZeEeSWyzUOh2sEEBXfQ6ufSy7+4Le8c9e62Gy/wakT
9lFN6iNfociA/zh1gN37eyZZra3nnocvDgmuDUqu9YeGxPoq+ExXH6n2n7asjKls
N04DuCeEWT4ed0KzZWUATAV2OZ2jUTQ9QgqDbIzfT/sp54LcsfaCEQaGpX2EVRbp
v/j+MpZi8UxFgNUvUHcDuOZ2vcEA9Xk8kemrKirjLAuonzLHI/Zj9ButnnkZWtRt
pWUmVznqBXaxIMqcAeNDpi66q8ewm3D2RsS9JN20QBzdNKxJEfKVmgCRcltRofRY
vgkDtsKGNqOZlI1PzEVcW1YdoWapSrZUU08G777rsMa9s3flRT8G61GMz5hd5FUt
dmqcQMbzXrMEpohwPShDSysk17tLHzYC6R9bO0uhVIIaxFI6rab9cczAwc3h9Im2
UZfIo3VaQcIhPgMQj0K9YTlWmlB2ns2p1xYYC1OkV+IPDdl/TIk=
=cZ2t
-----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#36952; 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: Thu, 8 Aug 2019 20:30:02 UTC

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