diff options
| -rw-r--r-- | guix/profiles.scm | 80 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 83 | ||||
| -rw-r--r-- | guix/ui.scm | 24 |
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 |