11/13: profiles: Add generation manipulation procedures.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 06d45f4566469364b4c1fe6d3c71ecf58f5d4838
Author: Ludovic Courtès <address@hidden>
Date:   Mon Oct 26 23:01:06 2015 +0100

    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.
---
 guix/profiles.scm        |   80 +++++++++++++++++++++++++++++++++++++++++++-
 guix/scripts/package.scm |   83 ++-------------------------------------------
 guix/ui.scm              |   24 +++++++++++++
 3 files changed, 107 insertions(+), 80 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index fac322b..e8bd564 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 49df334..d868949 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 b7ed5e7..72208e7 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