summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-10-26 23:01:06 +0100
committerLudovic Courtès <ludo@gnu.org>2015-10-27 00:01:20 +0100
commit06d45f4566469364b4c1fe6d3c71ecf58f5d4838 (patch)
tree20704b607a28fb48ee922485e400b353184c3c89 /guix
parent3bb168b0997d2ba2ef15e8eef2890582c8a6df9c (diff)
profiles: Add generation manipulation procedures.
* guix/scripts/package.scm (delete-generations): Use 'delete-generation*' instead of 'delete-generation'. (guix-package)[process-actions]: Use 'roll-back*' instead of 'roll-back' and 'switch-to-generation*' instead of 'switch-to-generation'. (link-to-empty-profile, switch-to-generation, switch-to-previous-generation, roll-back, delete-generation): Move to... * guix/profiles.scm: ... here. Adjust to not print messages and to return values that can be used by user interfaces. * guix/ui.scm (display-generation-change, roll-back*, switch-to-generation*, delete-generation*): New procedures.
Diffstat (limited to 'guix')
-rw-r--r--guix/profiles.scm80
-rw-r--r--guix/scripts/package.scm83
-rw-r--r--guix/ui.scm24
3 files changed, 107 insertions, 80 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm
index fac322bbab..e8bd564efa 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -84,13 +84,17 @@
packages->manifest
%default-profile-hooks
profile-derivation
+
generation-number
generation-numbers
profile-generations
relative-generation
previous-generation-number
generation-time
- generation-file-name))
+ generation-file-name
+ switch-to-generation
+ roll-back
+ delete-generation))
;;; Commentary:
;;;
@@ -844,4 +848,78 @@ case when generations have been deleted (there are \"holes\")."
(make-time time-utc 0
(stat:ctime (stat (generation-file-name profile number)))))
+(define (link-to-empty-profile store generation)
+ "Link GENERATION, a string, to the empty profile. An error is raised if
+that fails."
+ (let* ((drv (run-with-store store
+ (profile-derivation (manifest '()))))
+ (prof (derivation->output-path drv "out")))
+ (build-derivations store (list drv))
+ (switch-symlinks generation prof)))
+
+(define (switch-to-generation profile number)
+ "Atomically switch PROFILE to the generation NUMBER. Return the number of
+the generation that was current before switching."
+ (let ((current (generation-number profile))
+ (generation (generation-file-name profile number)))
+ (cond ((not (file-exists? profile))
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
+ ((not (file-exists? generation))
+ (raise (condition (&missing-generation-error
+ (profile profile)
+ (generation number)))))
+ (else
+ (switch-symlinks profile generation)
+ current))))
+
+(define (switch-to-previous-generation profile)
+ "Atomically switch PROFILE to the previous generation. Return the former
+generation number and the current one."
+ (let ((previous (previous-generation-number profile)))
+ (values (switch-to-generation profile previous)
+ previous)))
+
+(define (roll-back store profile)
+ "Roll back to the previous generation of PROFILE. Return the number of the
+generation that was current before switching and the new generation number."
+ (let* ((number (generation-number profile))
+ (previous-number (previous-generation-number profile number))
+ (previous-generation (generation-file-name profile previous-number)))
+ (cond ((not (file-exists? profile)) ;invalid profile
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
+ ((zero? number) ;empty profile
+ (values number number))
+ ((or (zero? previous-number) ;going to emptiness
+ (not (file-exists? previous-generation)))
+ (link-to-empty-profile store previous-generation)
+ (switch-to-previous-generation profile))
+ (else ;anything else
+ (switch-to-previous-generation profile)))))
+
+(define (delete-generation store profile number)
+ "Delete generation with NUMBER from PROFILE. Return the file name of the
+generation that has been deleted, or #f if nothing was done (for instance
+because the NUMBER is zero.)"
+ (define (delete-and-return)
+ (let ((generation (generation-file-name profile number)))
+ (delete-file generation)
+ generation))
+
+ (let* ((current-number (generation-number profile))
+ (previous-number (previous-generation-number profile number))
+ (previous-generation (generation-file-name profile previous-number)))
+ (cond ((zero? number) #f) ;do not delete generation 0
+ ((and (= number current-number)
+ (not (file-exists? previous-generation)))
+ (link-to-empty-profile store previous-generation)
+ (switch-to-previous-generation profile)
+ (delete-and-return))
+ ((= number current-number)
+ (roll-back store profile)
+ (delete-and-return))
+ (else
+ (delete-and-return)))))
+
;;; profiles.scm ends here
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 49df3349e8..d8689490b7 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -48,11 +48,7 @@
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
- #:export (switch-to-generation
- switch-to-previous-generation
- roll-back
- delete-generation
- delete-generations
+ #:export (delete-generations
display-search-paths
guix-package))
@@ -100,81 +96,10 @@ indirectly, or PROFILE."
%user-profile-directory
profile))
-(define (link-to-empty-profile store generation)
- "Link GENERATION, a string, to the empty profile."
- (let* ((drv (run-with-store store
- (profile-derivation (manifest '()))))
- (prof (derivation->output-path drv "out")))
- (when (not (build-derivations store (list drv)))
- (leave (_ "failed to build the empty profile~%")))
-
- (switch-symlinks generation prof)))
-
-(define (switch-to-generation profile number)
- "Atomically switch PROFILE to the generation NUMBER."
- (let ((current (generation-number profile))
- (generation (generation-file-name profile number)))
- (cond ((not (file-exists? profile))
- (raise (condition (&profile-not-found-error
- (profile profile)))))
- ((not (file-exists? generation))
- (raise (condition (&missing-generation-error
- (profile profile)
- (generation number)))))
- (else
- (format #t (_ "switching from generation ~a to ~a~%")
- current number)
- (switch-symlinks profile generation)))))
-
-(define (switch-to-previous-generation profile)
- "Atomically switch PROFILE to the previous generation."
- (switch-to-generation profile
- (previous-generation-number profile)))
-
-(define (roll-back store profile)
- "Roll back to the previous generation of PROFILE."
- (let* ((number (generation-number profile))
- (previous-number (previous-generation-number profile number))
- (previous-generation (generation-file-name profile previous-number)))
- (cond ((not (file-exists? profile)) ; invalid profile
- (raise (condition (&profile-not-found-error
- (profile profile)))))
- ((zero? number) ; empty profile
- (format (current-error-port)
- (_ "nothing to do: already at the empty profile~%")))
- ((or (zero? previous-number) ; going to emptiness
- (not (file-exists? previous-generation)))
- (link-to-empty-profile store previous-generation)
- (switch-to-previous-generation profile))
- (else
- (switch-to-previous-generation profile))))) ; anything else
-
-(define (delete-generation store profile number)
- "Delete generation with NUMBER from PROFILE."
- (define (display-and-delete)
- (let ((generation (generation-file-name profile number)))
- (format #t (_ "deleting ~a~%") generation)
- (delete-file generation)))
-
- (let* ((current-number (generation-number profile))
- (previous-number (previous-generation-number profile number))
- (previous-generation (generation-file-name profile previous-number)))
- (cond ((zero? number)) ; do not delete generation 0
- ((and (= number current-number)
- (not (file-exists? previous-generation)))
- (link-to-empty-profile store previous-generation)
- (switch-to-previous-generation profile)
- (display-and-delete))
- ((= number current-number)
- (roll-back store profile)
- (display-and-delete))
- (else
- (display-and-delete)))))
-
(define (delete-generations store profile generations)
"Delete GENERATIONS from PROFILE.
GENERATIONS is a list of generation numbers."
- (for-each (cut delete-generation store profile <>)
+ (for-each (cut delete-generation* store profile <>)
generations))
(define (delete-matching-generations store profile pattern)
@@ -725,7 +650,7 @@ more information.~%"))
;; First roll back if asked to.
(cond ((and (assoc-ref opts 'roll-back?)
(not dry-run?))
- (roll-back (%store) profile)
+ (roll-back* (%store) profile)
(process-actions (alist-delete 'roll-back? opts)))
((and (assoc-ref opts 'switch-generation)
(not dry-run?))
@@ -739,7 +664,7 @@ more information.~%"))
(relative-generation profile number))
(else number)))))
(if number
- (switch-to-generation profile number)
+ (switch-to-generation* profile number)
(leave (_ "cannot switch to generation '~a'~%")
pattern)))
(process-actions (alist-delete 'switch-generation opts)))
diff --git a/guix/ui.scm b/guix/ui.scm
index b7ed5e7d4d..72208e7de7 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -86,6 +86,9 @@
matching-generations
display-generation
display-profile-content
+ roll-back*
+ switch-to-generation*
+ delete-generation*
run-guix-command
run-guix
program-name
@@ -1035,6 +1038,27 @@ way."
(manifest-entries
(profile-manifest (generation-file-name profile number))))))
+(define (display-generation-change previous current)
+ (format #t (_ "switched from generation ~a to ~a~%") previous current))
+
+(define (roll-back* store profile)
+ "Like 'roll-back', but display what is happening."
+ (call-with-values
+ (lambda ()
+ (roll-back store 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)))
+ (display-generation-change previous number)))
+
+(define (delete-generation* store profile generation)
+ "Like 'delete-generation', but display what is going on."
+ (format #t (_ "deleting ~a~%")
+ (generation-file-name profile generation))
+ (delete-generation store profile generation))
+
(define* (package-specification->name+version+output spec
#:optional (output "out"))
"Parse package specification SPEC and return three value: the specified