From unknown Wed Sep 10 19:49:14 2025 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable MIME-Version: 1.0 X-Mailer: MIME-tools 5.509 (Entity 5.509) Content-Type: text/plain; charset=utf-8 From: bug#36952 <36952@debbugs.gnu.org> To: bug#36952 <36952@debbugs.gnu.org> Subject: Status: [PATCH] machine: Implement 'roll-back-machine'. Reply-To: bug#36952 <36952@debbugs.gnu.org> Date: Thu, 11 Sep 2025 02:49:14 +0000 retitle 36952 [PATCH] machine: Implement 'roll-back-machine'. reassign 36952 guix-patches submitter 36952 zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) severity 36952 normal tag 36952 patch thanks From debbugs-submit-bounces@debbugs.gnu.org Wed Aug 07 08:45:35 2019 Received: (at submit) by debbugs.gnu.org; 7 Aug 2019 12:45:35 +0000 Received: from localhost ([127.0.0.1]:38155 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hvLJv-0000KN-3A for submit@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 ) id 1hvLJq-0000KB-97 for submit@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 ) id 1hvLJo-000786-LA for guix-patches@gnu.org; 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 ) id 1hvLJn-0003N6-1n for guix-patches@gnu.org; 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 ) id 1hvLJm-0003Lw-N6 for guix-patches@gnu.org; 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 ; Wed, 7 Aug 2019 12:45:24 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) To: guix-patches@gnu.org Subject: [PATCH] machine: Implement 'roll-back-machine'. Date: Wed, 07 Aug 2019 08:42:08 -0400 Message-ID: <87v9v94067.fsf@sdf.lonestar.org> 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@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 . =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----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Wed Aug 07 16:11:45 2019 Received: (at submit) by debbugs.gnu.org; 7 Aug 2019 20:11:45 +0000 Received: from localhost ([127.0.0.1]:39494 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hvSHg-0004ep-F0 for submit@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 ) id 1hvSHe-0004ef-0t for submit@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 ) id 1hvSHc-0002rT-CM for guix-patches@gnu.org; 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 ) id 1hvSHa-00008r-NY for guix-patches@gnu.org; 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 ) id 1hvSHa-00007B-IL for guix-patches@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@sdf.lonestar.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Lemmer Webber To: guix-patches@gnu.org Subject: Re: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'. In-reply-to: <87v9v94067.fsf@sdf.lonestar.org> Date: Wed, 07 Aug 2019 16:11:37 -0400 Message-ID: <87v9v8ohvq.fsf@dustycloud.org> 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@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 . > > (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)))) From debbugs-submit-bounces@debbugs.gnu.org Wed Aug 07 17:00:23 2019 Received: (at 36952) by debbugs.gnu.org; 7 Aug 2019 21:00:23 +0000 Received: from localhost ([127.0.0.1]:39559 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hvT2l-0008Kr-55 for submit@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 ) id 1hvT2j-0008Kh-Ho for 36952@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@sdf.lonestar.org (Jakob L. Kreuze) To: Christopher Lemmer Webber Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'. References: <87v9v94067.fsf@sdf.lonestar.org> <87v9v8ohvq.fsf@dustycloud.org> Date: Wed, 07 Aug 2019 16:57:06 -0400 In-Reply-To: <87v9v8ohvq.fsf@dustycloud.org> (Christopher Lemmer Webber's message of "Wed, 07 Aug 2019 16:11:37 -0400") Message-ID: <87v9v8k82l.fsf_-_@sdf.lonestar.org> 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@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 . =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----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Wed Aug 07 18:33:25 2019 Received: (at 36952) by debbugs.gnu.org; 7 Aug 2019 22:33:25 +0000 Received: from localhost ([127.0.0.1]:39631 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hvUUn-0004sS-Ak for submit@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 ) id 1hvUUl-0004sK-NK for 36952@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@sdf.lonestar.org> <87v9v8ohvq.fsf@dustycloud.org> <87v9v8k82l.fsf_-_@sdf.lonestar.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Lemmer Webber To: "Jakob L. Kreuze" , "David Thompson" Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'. In-reply-to: <87v9v8k82l.fsf_-_@sdf.lonestar.org> Date: Wed, 07 Aug 2019 18:33:22 -0400 Message-ID: <87r25wobbh.fsf@dustycloud.org> MIME-Version: 1.0 Content-Type: text/plain X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 36952 Cc: 36952@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 . > > (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)))) From debbugs-submit-bounces@debbugs.gnu.org Thu Aug 08 06:51:17 2019 Received: (at 36952) by debbugs.gnu.org; 8 Aug 2019 10:51:17 +0000 Received: from localhost ([127.0.0.1]:39976 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hvg0r-0005Ae-IP for submit@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 ) id 1hvg0l-0005AS-Ey for 36952@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@elephly.net; dmarc=pass header.from= header.from= DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; t=1565261467; s=zoho; d=elephly.net; i=rekado@elephly.net; 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@sdf.lonestar.org> <87v9v8ohvq.fsf@dustycloud.org> <87v9v8k82l.fsf_-_@sdf.lonestar.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Ricardo Wurmus To: Jakob L. Kreuze Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'. In-reply-to: <87v9v8k82l.fsf_-_@sdf.lonestar.org> 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@elephly.net> 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 , 36952@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 From debbugs-submit-bounces@debbugs.gnu.org Thu Aug 08 16:16:56 2019 Received: (at 36952) by debbugs.gnu.org; 8 Aug 2019 20:16:56 +0000 Received: from localhost ([127.0.0.1]:41748 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hvoqG-0003pf-Hw for submit@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 ) id 1hvoqA-0003pR-8t for 36952@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@sdf.lonestar.org (Jakob L. Kreuze) To: Ricardo Wurmus Subject: Re: [bug#36952] [PATCH v2] machine: Implement 'roll-back-machine'. References: <87v9v94067.fsf@sdf.lonestar.org> <87v9v8ohvq.fsf@dustycloud.org> <87v9v8k82l.fsf_-_@sdf.lonestar.org> <87v9v8vskt.fsf@elephly.net> Date: Thu, 08 Aug 2019 16:16:35 -0400 In-Reply-To: <87v9v8vskt.fsf@elephly.net> (Ricardo Wurmus's message of "Thu, 08 Aug 2019 12:50:58 +0200") Message-ID: <8736ibl8f0.fsf@sdf.lonestar.org> 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 , 36952@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hi Ricardo, Ricardo Wurmus 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----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Thu Aug 08 16:17:31 2019 Received: (at 36952) by debbugs.gnu.org; 8 Aug 2019 20:17:31 +0000 Received: from localhost ([127.0.0.1]:41752 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hvoqo-0003qq-TO for submit@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 ) id 1hvoqn-0003qi-Jl for 36952@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@sdf.lonestar.org (Jakob L. Kreuze) To: Ricardo Wurmus Subject: Re: [bug#36952] [PATCH v3] machine: Implement 'roll-back-machine'. References: <87v9v94067.fsf@sdf.lonestar.org> <87v9v8ohvq.fsf@dustycloud.org> <87v9v8k82l.fsf_-_@sdf.lonestar.org> <87v9v8vskt.fsf@elephly.net> Date: Thu, 08 Aug 2019 16:17:24 -0400 In-Reply-To: <87v9v8vskt.fsf@elephly.net> (Ricardo Wurmus's message of "Thu, 08 Aug 2019 12:50:58 +0200") Message-ID: <87y303jtt7.fsf_-_@sdf.lonestar.org> 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 , 36952@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 . =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----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Wed Aug 14 16:49:54 2019 Received: (at submit) by debbugs.gnu.org; 14 Aug 2019 20:49:54 +0000 Received: from localhost ([127.0.0.1]:49781 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hy0DP-0000bR-UP for submit@debbugs.gnu.org; Wed, 14 Aug 2019 16:49:54 -0400 Received: from lists.gnu.org ([209.51.188.17]:50554) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hy0DM-0000bD-OI for submit@debbugs.gnu.org; Wed, 14 Aug 2019 16:49:49 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:38114) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1hy0DK-0001VP-VJ for guix-patches@gnu.org; Wed, 14 Aug 2019 16:49:48 -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 ) id 1hy0DJ-0001wD-6W for guix-patches@gnu.org; Wed, 14 Aug 2019 16:49:46 -0400 Received: from dustycloud.org ([50.116.34.160]:56968) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1hy0DJ-0001vG-1N for guix-patches@gnu.org; Wed, 14 Aug 2019 16:49:45 -0400 Received: from twig (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id EF92026630; Wed, 14 Aug 2019 16:49:43 -0400 (EDT) References: <87v9v94067.fsf@sdf.lonestar.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Lemmer Webber To: guix-patches@gnu.org Subject: Re: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'. In-reply-to: <87v9v94067.fsf@sdf.lonestar.org> Date: Wed, 14 Aug 2019 16:49:43 -0400 Message-ID: <87k1bfxyjc.fsf@dustycloud.org> 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@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -2.3 (--) Looks good. Will merge when in patch series form. 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 . > > (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)))) From debbugs-submit-bounces@debbugs.gnu.org Thu Aug 15 07:45:46 2019 Received: (at 36952-done) by debbugs.gnu.org; 15 Aug 2019 11:45:46 +0000 Received: from localhost ([127.0.0.1]:50739 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hyECQ-0003lE-F4 for submit@debbugs.gnu.org; Thu, 15 Aug 2019 07:45:46 -0400 Received: from dustycloud.org ([50.116.34.160]:43310) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hyECN-0003l5-3J for 36952-done@debbugs.gnu.org; Thu, 15 Aug 2019 07:45:43 -0400 Received: from twig (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id BB93C266AD for <36952-done@debbugs.gnu.org>; Thu, 15 Aug 2019 07:45:42 -0400 (EDT) References: <87v9v94067.fsf@sdf.lonestar.org> <87k1bfxyjc.fsf@dustycloud.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Lemmer Webber To: 36952-done@debbugs.gnu.org Subject: Re: [bug#36952] [PATCH] machine: Implement 'roll-back-machine'. In-reply-to: <87k1bfxyjc.fsf@dustycloud.org> Date: Thu, 15 Aug 2019 07:45:42 -0400 Message-ID: <87d0h6y7mh.fsf@dustycloud.org> MIME-Version: 1.0 Content-Type: text/plain X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 36952-done X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) Merged and pushed! From unknown Wed Sep 10 19:49:14 2025 Received: (at fakecontrol) by fakecontrolmessage; To: internal_control@debbugs.gnu.org From: Debbugs Internal Request Subject: Internal Control Message-Id: bug archived. Date: Fri, 13 Sep 2019 11:24:08 +0000 User-Agent: Fakemail v42.6.9 # This is a fake control message. # # The action: # bug archived. thanks # This fakemail brought to you by your local debbugs # administrator