From 00f8b1ccea6c80e37535cd16b05bafbb9cf3686b Mon Sep 17 00:00:00 2001 From: Chris Marusich Date: Fri, 8 Jul 2016 13:49:25 -0700 Subject: [PATCH] Implement system roll-back and switch-generation commands Right now, they just switch symlinks. --- guix/profiles.scm | 21 ++++++++++++++++- guix/scripts/package.scm | 7 +----- guix/scripts/system.scm | 59 +++++++++++++++++++++++++++++++++++++----------- guix/ui.scm | 8 +++++++ 4 files changed, 75 insertions(+), 20 deletions(-) diff --git a/guix/profiles.scm b/guix/profiles.scm index 90c4332..9b0ce7f 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -90,11 +90,13 @@ generation-number generation-numbers profile-generations + relative-generation-spec->number relative-generation previous-generation-number generation-time generation-file-name switch-to-generation + switch-to-previous-generation roll-back delete-generation)) @@ -896,6 +898,21 @@ former profiles were found." '() generations))) +(define (relative-generation-spec->number profile spec) + "Return PROFILE's generation specified by SPEC, which is a string. The SPEC +may be a N, -N, or +N, where N is a number. If the spec is N, then the number +returned is N. If it is -N, then the number returned is the profile's current +generation number minus N. If it is +N, then the number returned is the +profile's current generation number plus N. Return #f if there is no such +generation." + (let ((number (string->number spec))) + (and number + (case (string-ref spec 0) + ((#\+ #\-) + (relative-generation profile number)) + (else number))))) + + (define* (relative-generation profile shift #:optional (current (generation-number profile))) "Return PROFILE's generation shifted from the CURRENT generation by SHIFT. @@ -939,7 +956,9 @@ that fails." (define (switch-to-generation profile number) "Atomically switch PROFILE to the generation NUMBER. Return the number of -the generation that was current before switching." +the generation that was current before switching. Raise a +&profile-not-found-error when the profile does not exist. Raise a +&missing-generation-error when the generation does not exist." (let ((current (generation-number profile)) (generation (generation-file-name profile number))) (cond ((not (file-exists? profile)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e2e3709..8df5145 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -743,12 +743,7 @@ processed, #f otherwise." #:key dry-run?) "Switch PROFILE to the generation specified by SPEC." (unless dry-run? - (let* ((number (string->number spec)) - (number (and number - (case (string-ref spec 0) - ((#\+ #\-) - (relative-generation profile number)) - (else number))))) + (let ((number (relative-generation-spec->number profile spec))) (if number (switch-to-generation* profile number) (leave (_ "cannot switch to generation '~a'~%") spec))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index dd1e534..3548d54 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -418,6 +418,23 @@ it atomically, and then run OS's activation script." ;;; +;;; Roll-back. +;;; +(define (roll-back-system) + "Roll back the system profile to its previous generation." + (switch-to-previous-generation* %system-profile)) + +;;; +;;; Switch generations. +;;; +(define (switch-to-system-generation spec) + "Switch the system profile to the generation specified by SPEC." + (let ((number (relative-generation-spec->number %system-profile spec))) + (if number + (switch-to-generation* %system-profile number) + (leave (_ "cannot switch to system generation '~a'~%") spec)))) + +;;; ;;; Graphs. ;;; @@ -649,31 +666,36 @@ building anything." ;;; (define (show-help) - (display (_ "Usage: guix system [OPTION] ACTION [FILE] -Build the operating system declared in FILE according to ACTION.\n")) + (display (_ "Usage: guix system [OPTION ...] ACTION [ARG ...] [FILE] +Build the operating system declared in FILE according to ACTION. +Some ACTIONS support additional ARGS.\n")) (newline) (display (_ "The valid values for ACTION are:\n")) (newline) (display (_ "\ - reconfigure switch to a new operating system configuration\n")) + reconfigure switch to a new operating system configuration\n")) + (display (_ "\ + roll-back switch to the previous operating system configuration\n")) (display (_ "\ - list-generations list the system generations\n")) + switch-generation switch to a generation matching a pattern\n")) (display (_ "\ - build build the operating system without installing anything\n")) + list-generations list the system generations\n")) (display (_ "\ - container build a container that shares the host's store\n")) + build build the operating system without installing anything\n")) (display (_ "\ - vm build a virtual machine image that shares the host's store\n")) + container build a container that shares the host's store\n")) (display (_ "\ - vm-image build a freestanding virtual machine image\n")) + vm build a virtual machine image that shares the host's store\n")) (display (_ "\ - disk-image build a disk image, suitable for a USB stick\n")) + vm-image build a freestanding virtual machine image\n")) (display (_ "\ - init initialize a root file system to run GNU\n")) + disk-image build a disk image, suitable for a USB stick\n")) (display (_ "\ - extension-graph emit the service extension graph in Dot format\n")) + init initialize a root file system to run GNU\n")) (display (_ "\ - shepherd-graph emit the graph of shepherd services in Dot format\n")) + extension-graph emit the service extension graph in Dot format\n")) + (display (_ "\ + shepherd-graph emit the graph of shepherd services in Dot format\n")) (show-build-options-help) (display (_ " @@ -824,6 +846,16 @@ argument list and OPTS is the option alist." ((pattern) pattern) (x (leave (_ "wrong number of arguments~%")))))) (list-generations pattern))) + ((roll-back) + (let ((pattern (match args + (() "") + (x (leave (_ "wrong number of arguments~%")))))) + (roll-back-system))) + ((switch-generation) + (let ((pattern (match args + ((pattern) pattern) + (x (leave (_ "wrong number of arguments~%")))))) + (switch-to-system-generation pattern))) (else (process-action command args opts)))) @@ -835,7 +867,8 @@ argument list and OPTS is the option alist." (let ((action (string->symbol arg))) (case action ((build container vm vm-image disk-image reconfigure init - extension-graph shepherd-graph list-generations) + extension-graph shepherd-graph list-generations roll-back + switch-generation) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) diff --git a/guix/ui.scm b/guix/ui.scm index 4d1b65c..fcf403c 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -90,6 +90,7 @@ display-generation display-profile-content roll-back* + switch-to-previous-generation* switch-to-generation* delete-generation* run-guix-command @@ -1095,6 +1096,13 @@ way." (roll-back store profile)) display-generation-change)) +(define (switch-to-previous-generation* profile) + "Like switch-to-previous-generation, but display what is happening." + (call-with-values + (lambda () + (switch-to-previous-generation profile)) + display-generation-change)) + (define (switch-to-generation* profile number) "Like 'switch-generation', but display what is happening." (let ((previous (switch-to-generation profile number))) -- 2.7.3