Add (guix profiles).

* guix/scripts/package.scm (show-what-to-remove/install): New procedure,
  moved from...
  (guix-package): ... here.
  (<manifest>, make-manifest, <manifest-entry>,
  profile-manifest, manifest->sexp, sexp->manifest, read-manifest,
  write-manifest, remove-manifest-entry, manifest-remove,
  manifest-installed?, manifest=?, profile-regexp, generation-numbers,
  previous-generation-number, profile-derivation, generation-number,
  generation-file-name, generation-time, lower-input): Move to...
* guix/profiles.scm: ... here.  New file.
* Makefile.am (MODULES): Add it.

1 files changed, 46 insertions, 297 deletions

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 008ae53b47..4dbe2b7b63 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -23,22 +23,19 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix profiles)
   #:use-module (guix utils)
   #:use-module (guix config)
-  #:use-module (guix records)
   #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
   #:use-module ((guix ftp-client) #:select (ftp-open))
-  #:use-module (ice-9 ftw)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:use-module (gnu packages)
   #:use-module ((gnu packages base) #:select (guile-final))
@@ -51,7 +48,7 @@
 
 
 ;;;
-;;; User profile.
+;;; Profiles.
 ;;;
 
 (define %user-profile-directory
@@ -69,240 +66,6 @@
   ;; coexist with Nix profiles.
   (string-append %profile-directory "/guix-profile"))
 
-
-;;;
-;;; Manifests.
-;;;
-
-(define-record-type <manifest>
-  (manifest entries)
-  manifest?
-  (entries manifest-entries))                     ; list of <manifest-entry>
-
-;; Convenient alias, to avoid name clashes.
-(define make-manifest manifest)
-
-(define-record-type* <manifest-entry> manifest-entry
-  make-manifest-entry
-  manifest-entry?
-  (name         manifest-entry-name)              ; string
-  (version      manifest-entry-version)           ; string
-  (output       manifest-entry-output             ; string
-                (default "out"))
-  (path         manifest-entry-path)              ; store path
-  (dependencies manifest-entry-dependencies       ; list of store paths
-                (default '()))
-  (inputs       manifest-entry-inputs             ; list of inputs to build
-                (default '())))                   ; this entry
-
-(define (profile-manifest profile)
-  "Return the PROFILE's manifest."
-  (let ((file (string-append profile "/manifest")))
-    (if (file-exists? file)
-        (call-with-input-file file read-manifest)
-        (manifest '()))))
-
-(define (manifest->sexp manifest)
-  "Return a representation of MANIFEST as an sexp."
-  (define (entry->sexp entry)
-    (match entry
-      (($ <manifest-entry> name version path output (deps ...))
-       (list name version path output deps))))
-
-  (match manifest
-    (($ <manifest> (entries ...))
-     `(manifest (version 1)
-                (packages ,(map entry->sexp entries))))))
-
-(define (sexp->manifest sexp)
-  "Parse SEXP as a manifest."
-  (match sexp
-    (('manifest ('version 0)
-                ('packages ((name version output path) ...)))
-     (manifest
-      (map (lambda (name version output path)
-             (manifest-entry
-              (name name)
-              (version version)
-              (output output)
-              (path path)))
-           name version output path)))
-
-    ;; Version 1 adds a list of propagated inputs to the
-    ;; name/version/output/path tuples.
-    (('manifest ('version 1)
-                ('packages ((name version output path deps) ...)))
-     (manifest
-      (map (lambda (name version output path deps)
-             (manifest-entry
-              (name name)
-              (version version)
-              (output output)
-              (path path)
-              (dependencies deps)))
-           name version output path deps)))
-
-    (_
-     (error "unsupported manifest format" manifest))))
-
-(define (read-manifest port)
-  "Return the packages listed in MANIFEST."
-  (sexp->manifest (read port)))
-
-(define (write-manifest manifest port)
-  "Write MANIFEST to PORT."
-  (write (manifest->sexp manifest) port))
-
-(define (remove-manifest-entry name lst)
-  "Remove the manifest entry named NAME from LST."
-  (remove (match-lambda
-           (($ <manifest-entry> entry-name)
-            (string=? name entry-name)))
-          lst))
-
-(define (manifest-remove manifest names)
-  "Remove entries for each of NAMES from MANIFEST."
-  (make-manifest (fold remove-manifest-entry
-                       (manifest-entries manifest)
-                       names)))
-
-(define (manifest-installed? manifest name)
-  "Return #t if MANIFEST has an entry for NAME, #f otherwise."
-  (define (->bool x)
-    (not (not x)))
-
-  (->bool (find (match-lambda
-                 (($ <manifest-entry> entry-name)
-                  (string=? entry-name name)))
-                (manifest-entries manifest))))
-
-(define (manifest=? m1 m2)
-  "Return #t if manifests M1 and M2 are equal.  This differs from 'equal?' in
-that the 'inputs' field is ignored for the comparison, since it is know to
-have no effect on the manifest contents."
-  (equal? (manifest->sexp m1)
-          (manifest->sexp m2)))
-
-
-;;;
-;;; Profiles.
-;;;
-
-(define (profile-regexp profile)
-  "Return a regular expression that matches PROFILE's name and number."
-  (make-regexp (string-append "^" (regexp-quote (basename profile))
-                              "-([0-9]+)")))
-
-(define (generation-numbers profile)
-  "Return the sorted list of generation numbers of PROFILE, or '(0) if no
-former profiles were found."
-  (define* (scandir name #:optional (select? (const #t))
-                    (entry<? (@ (ice-9 i18n) string-locale<?)))
-    ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
-    (define (enter? dir stat result)
-      (and stat (string=? dir name)))
-
-    (define (visit basename result)
-      (if (select? basename)
-          (cons basename result)
-          result))
-
-    (define (leaf name stat result)
-      (and result
-           (visit (basename name) result)))
-
-    (define (down name stat result)
-      (visit "." '()))
-
-    (define (up name stat result)
-      (visit ".." result))
-
-    (define (skip name stat result)
-      ;; All the sub-directories are skipped.
-      (visit (basename name) result))
-
-    (define (error name* stat errno result)
-      (if (string=? name name*)             ; top-level NAME is unreadable
-          result
-          (visit (basename name*) result)))
-
-    (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
-           (lambda (files)
-             (sort files entry<?))))
-
-  (match (scandir (dirname profile)
-                  (cute regexp-exec (profile-regexp profile) <>))
-    (#f                                         ; no profile directory
-     '(0))
-    (()                                         ; no profiles
-     '(0))
-    ((profiles ...)                             ; former profiles around
-     (sort (map (compose string->number
-                         (cut match:substring <> 1)
-                         (cute regexp-exec (profile-regexp profile) <>))
-                profiles)
-           <))))
-
-(define (previous-generation-number profile number)
-  "Return the number of the generation before generation NUMBER of
-PROFILE, or 0 if none exists.  It could be NUMBER - 1, but it's not the
-case when generations have been deleted (there are \"holes\")."
-  (fold (lambda (candidate highest)
-          (if (and (< candidate number) (> candidate highest))
-              candidate
-              highest))
-        0
-        (generation-numbers profile)))
-
-(define (profile-derivation store manifest)
-  "Return a derivation that builds a profile (aka. 'user environment') with
-the given MANIFEST."
-  (define builder
-    `(begin
-       (use-modules (ice-9 pretty-print)
-                    (guix build union))
-
-       (setvbuf (current-output-port) _IOLBF)
-       (setvbuf (current-error-port) _IOLBF)
-
-       (let ((output (assoc-ref %outputs "out"))
-             (inputs (map cdr %build-inputs)))
-         (format #t "building profile '~a' with ~a packages...~%"
-                 output (length inputs))
-         (union-build output inputs
-                      #:log-port (%make-void-port "w"))
-         (call-with-output-file (string-append output "/manifest")
-           (lambda (p)
-             (pretty-print ',(manifest->sexp manifest) p))))))
-
-  (build-expression->derivation store "profile"
-                                (%current-system)
-                                builder
-                                (append-map (match-lambda
-                                             (($ <manifest-entry> name version
-                                                 output path deps (inputs ..1))
-                                              (map (cute lower-input
-                                                         (%store) <>)
-                                                   inputs))
-                                             (($ <manifest-entry> name version
-                                                 output path deps)
-                                              ;; Assume PATH and DEPS are
-                                              ;; already valid.
-                                              `((,name ,path) ,@deps)))
-                                            (manifest-entries manifest))
-                                #:modules '((guix build union))))
-
-(define (generation-number profile)
-  "Return PROFILE's number or 0.  An absolute file name must be used."
-  (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
-                                              (basename (readlink profile))))
-             (compose string->number (cut match:substring <> 1)))
-      0))
-
-(define (generation-file-name profile generation)
-  "Return the file name for PROFILE's GENERATION."
-  (format #f "~a-~a-link" profile generation))
-
 (define (link-to-empty-profile generation)
   "Link GENERATION, a string, to the empty profile."
   (let* ((drv  (profile-derivation (%store) (manifest '())))
@@ -340,11 +103,6 @@ the given MANIFEST."
           (else
            (switch-to-previous-generation profile)))))  ; anything else
 
-(define (generation-time profile number)
-  "Return the creation time of a generation in the UTC format."
-  (make-time time-utc 0
-             (stat:ctime (stat (generation-file-name profile number)))))
-
 (define* (matching-generations str #:optional (profile %current-profile)
                                #:key (duration-relation <=))
   "Return the list of available generations matching a pattern in STR.  See
@@ -411,6 +169,50 @@ DURATION-RELATION with the current time."
          filter-by-duration)
         (else #f)))
 
+(define (show-what-to-remove/install remove install dry-run?)
+  "Given the manifest entries listed in REMOVE and INSTALL, display the
+packages that will/would be installed and removed."
+  ;; TODO: Report upgrades more clearly.
+  (match remove
+    ((($ <manifest-entry> name version _ path _) ..1)
+     (let ((len    (length name))
+           (remove (map (cut format #f "  ~a-~a\t~a" <> <> <>)
+                        name version path)))
+       (if dry-run?
+           (format (current-error-port)
+                   (N_ "The following package would be removed:~% ~{~a~%~}~%"
+                       "The following packages would be removed:~% ~{~a~%~}~%"
+                       len)
+                   remove)
+           (format (current-error-port)
+                   (N_ "The following package will be removed:~% ~{~a~%~}~%"
+                       "The following packages will be removed:~% ~{~a~%~}~%"
+                       len)
+                   remove))))
+    (_ #f))
+  (match install
+    ((($ <manifest-entry> name version output path _) ..1)
+     (let ((len     (length name))
+           (install (map (cut format #f "   ~a-~a\t~a\t~a" <> <> <> <>)
+                         name version output path)))
+       (if dry-run?
+           (format (current-error-port)
+                   (N_ "The following package would be installed:~%~{~a~%~}~%"
+                       "The following packages would be installed:~%~{~a~%~}~%"
+                       len)
+                   install)
+           (format (current-error-port)
+                   (N_ "The following package will be installed:~%~{~a~%~}~%"
+                       "The following packages will be installed:~%~{~a~%~}~%"
+                       len)
+                   install))))
+    (_ #f)))
+
+
+;;;
+;;; Package specifications.
+;;;
+
 (define (find-packages-by-description rx)
   "Return the list of packages whose name, synopsis, or description matches
 RX."
@@ -437,16 +239,6 @@ RX."
                 (package-name p2))))
    same-location?))
 
-(define* (lower-input store input #:optional (system (%current-system)))
-  "Lower INPUT so that it contains derivations instead of packages."
-  (match input
-    ((name (? package? package))
-     `(,name ,(package-derivation store package system)))
-    ((name (? package? package) output)
-     `(,name ,(package-derivation store package system)
-             ,output))
-    (_ input)))
-
 (define (input->name+path input)
   "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
   (let loop ((input input))
@@ -500,11 +292,6 @@ return its return value."
        (format (current-error-port) "  interrupted by signal ~a~%" SIGINT)
        #f))))
 
-
-;;;
-;;; Package specifications.
-;;;
-
 (define newest-available-packages
   (memoize find-newest-available-packages))
 
@@ -989,44 +776,6 @@ more information.~%"))
          (and (equal? name entry-name)
               (equal? output entry-output)))))
 
-    (define (show-what-to-remove/install remove install dry-run?)
-      ;; Tell the user what's going to happen in high-level terms.
-      ;; TODO: Report upgrades more clearly.
-      (match remove
-        ((($ <manifest-entry> name version _ path _) ..1)
-         (let ((len    (length name))
-               (remove (map (cut format #f "  ~a-~a\t~a" <> <> <>)
-                            name version path)))
-           (if dry-run?
-               (format (current-error-port)
-                       (N_ "The following package would be removed:~% ~{~a~%~}~%"
-                           "The following packages would be removed:~% ~{~a~%~}~%"
-                           len)
-                       remove)
-               (format (current-error-port)
-                       (N_ "The following package will be removed:~% ~{~a~%~}~%"
-                           "The following packages will be removed:~% ~{~a~%~}~%"
-                           len)
-                       remove))))
-        (_ #f))
-      (match install
-        ((($ <manifest-entry> name version output path _) ..1)
-         (let ((len     (length name))
-               (install (map (cut format #f "   ~a-~a\t~a\t~a" <> <> <> <>)
-                             name version output path)))
-           (if dry-run?
-               (format (current-error-port)
-                       (N_ "The following package would be installed:~%~{~a~%~}~%"
-                           "The following packages would be installed:~%~{~a~%~}~%"
-                           len)
-                       install)
-               (format (current-error-port)
-                       (N_ "The following package will be installed:~%~{~a~%~}~%"
-                           "The following packages will be installed:~%~{~a~%~}~%"
-                           len)
-                       install))))
-        (_ #f)))
-
     (define current-generation-number
       (generation-number profile))