Merge branch 'master' into core-updates

4 files changed, 184 insertions, 52 deletions

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 26cd28215e..a06755dc7a 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -250,7 +250,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
                                    (derivations-from-package-expressions
                                     str package->derivation sys src?))
                                   (('argument . (? derivation-path? drv))
-                                   drv)
+                                   (call-with-input-file drv read-derivation))
                                   (('argument . (? string? x))
                                    (let ((p (find-package x)))
                                      (if src?
@@ -280,24 +280,23 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
 
           (if (assoc-ref opts 'derivations-only?)
               (begin
-                (format #t "~{~a~%~}" drv)
+                (format #t "~{~a~%~}" (map derivation-file-name drv))
                 (for-each (cut register-root <> <>)
-                          (map list drv) roots))
+                          (map (compose list derivation-file-name) drv)
+                          roots))
               (or (assoc-ref opts 'dry-run?)
                   (and (build-derivations (%store) drv)
                        (for-each (lambda (d)
-                                   (let ((drv (call-with-input-file d
-                                                read-derivation)))
-                                     (format #t "~{~a~%~}"
-                                             (map (match-lambda
-                                                   ((out-name . out)
-                                                    (derivation-path->output-path
-                                                     d out-name)))
-                                                  (derivation-outputs drv)))))
+                                   (format #t "~{~a~%~}"
+                                           (map (match-lambda
+                                                 ((out-name . out)
+                                                  (derivation->output-path
+                                                   d out-name)))
+                                                (derivation-outputs d))))
                                  drv)
                        (for-each (cut register-root <> <>)
                                  (map (lambda (drv)
                                         (map cdr
-                                             (derivation-path->output-paths drv)))
+                                             (derivation->output-paths drv)))
                                       drv)
                                  roots)))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5c3947dd63..1d00e39540 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -34,6 +34,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #: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)
@@ -95,8 +96,8 @@
   (make-regexp (string-append "^" (regexp-quote (basename profile))
                               "-([0-9]+)")))
 
-(define (profile-numbers profile)
-  "Return the list of generation numbers of PROFILE, or '(0) if no
+(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<?)))
@@ -139,12 +140,13 @@ former profiles were found."
     (()                                         ; no profiles
      '(0))
     ((profiles ...)                             ; former profiles around
-     (map (compose string->number
-                   (cut match:substring <> 1)
-                   (cute regexp-exec (profile-regexp profile) <>))
-          profiles))))
+     (sort (map (compose string->number
+                         (cut match:substring <> 1)
+                         (cute regexp-exec (profile-regexp profile) <>))
+                profiles)
+           <))))
 
-(define (previous-profile-number profile number)
+(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\")."
@@ -153,7 +155,7 @@ case when generations have been deleted (there are \"holes\")."
               candidate
               highest))
         0
-        (profile-numbers profile)))
+        (generation-numbers profile)))
 
 (define (profile-derivation store packages)
   "Return a derivation that builds a profile (a user environment) with
@@ -205,7 +207,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
                                             packages)
                                 #:modules '((guix build union))))
 
-(define (profile-number profile)
+(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))))
@@ -214,17 +216,17 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
 
 (define (roll-back profile)
   "Roll back to the previous generation of PROFILE."
-  (let* ((number           (profile-number profile))
-         (previous-number  (previous-profile-number profile number))
-         (previous-profile (format #f "~a-~a-link"
-                                   profile previous-number))
-         (manifest         (string-append previous-profile "/manifest")))
+  (let* ((number              (generation-number profile))
+         (previous-number     (previous-generation-number profile number))
+         (previous-generation (format #f "~a-~a-link"
+                                      profile previous-number))
+         (manifest            (string-append previous-generation "/manifest")))
 
     (define (switch-link)
-      ;; Atomically switch PROFILE to the previous profile.
+      ;; Atomically switch PROFILE to the previous generation.
       (format #t (_ "switching from generation ~a to ~a~%")
               number previous-number)
-      (switch-symlinks profile previous-profile))
+      (switch-symlinks profile previous-generation))
 
     (cond ((not (file-exists? profile))           ; invalid profile
            (leave (_ "profile `~a' does not exist~%")
@@ -233,19 +235,84 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
            (format (current-error-port)
                    (_ "nothing to do: already at the empty profile~%")))
           ((or (zero? previous-number)            ; going to emptiness
-               (not (file-exists? previous-profile)))
-           (let*-values (((drv-path drv)
-                          (profile-derivation (%store) '()))
-                         ((prof)
-                          (derivation-output-path
-                           (assoc-ref (derivation-outputs drv) "out"))))
-             (when (not (build-derivations (%store) (list drv-path)))
+               (not (file-exists? previous-generation)))
+           (let* ((drv  (profile-derivation (%store) '()))
+                  (prof (derivation->output-path drv "out")))
+             (when (not (build-derivations (%store) (list drv)))
                (leave (_ "failed to build the empty profile~%")))
 
-             (switch-symlinks previous-profile prof)
+             (switch-symlinks previous-generation prof)
              (switch-link)))
           (else (switch-link)))))                 ; 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 (format #f "~a-~a-link" profile number)))))
+
+(define* (matching-generations str #:optional (profile %current-profile))
+  "Return the list of available generations matching a pattern in STR.  See
+'string->generations' and 'string->duration' for the list of valid patterns."
+  (define (valid-generations lst)
+    (define (valid-generation? n)
+      (any (cut = n <>) (generation-numbers profile)))
+
+    (fold-right (lambda (x acc)
+                  (if (valid-generation? x)
+                      (cons x acc)
+                      acc))
+                '()
+                lst))
+
+  (define (filter-generations generations)
+    (match generations
+      (() '())
+      (('>= n)
+       (drop-while (cut > n <>)
+                   (generation-numbers profile)))
+      (('<= n)
+       (valid-generations (iota n 1)))
+      ((lst ..1)
+       (valid-generations lst))
+      (_ #f)))
+
+  (define (filter-by-duration duration)
+    (define (time-at-midnight time)
+      ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
+      ;; hours to zeros.
+      (let ((d (time-utc->date time)))
+         (date->time-utc
+          (make-date 0 0 0 0
+                     (date-day d) (date-month d)
+                     (date-year d) (date-zone-offset d)))))
+
+    (define generation-ctime-alist
+      (map (lambda (number)
+             (cons number
+                   (time-second
+                    (time-at-midnight
+                     (generation-time profile number)))))
+           (generation-numbers profile)))
+
+    (match duration
+      (#f #f)
+      (res
+       (let ((s (time-second
+                 (subtract-duration (time-at-midnight (current-time))
+                                    duration))))
+         (delete #f (map (lambda (x)
+                           (and (<= s (cdr x))
+                                (first x)))
+                         generation-ctime-alist))))))
+
+  (cond ((string->generations str)
+         =>
+         filter-generations)
+        ((string->duration str)
+         =>
+         filter-by-duration)
+        (else #f)))
+
 (define (find-packages-by-description rx)
   "Search in SYNOPSIS and DESCRIPTION using RX.  Return a list of
 matching packages."
@@ -441,6 +508,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
       --roll-back        roll back to the previous generation"))
   (display (_ "
       --search-paths     display needed environment variable definitions"))
+  (display (_ "
+  -l, --list-generations[=PATTERN]
+                         list generations matching PATTERN"))
   (newline)
   (display (_ "
   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
@@ -500,6 +570,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
         (option '("roll-back") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'roll-back? #t result)))
+        (option '(#\l "list-generations") #f #t
+                (lambda (opt name arg result)
+                  (cons `(query list-generations ,(or arg ""))
+                        result)))
         (option '("search-paths") #f #f
                 (lambda (opt name arg result)
                   (cons `(query search-paths) result)))
@@ -558,7 +632,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
 
   (define (guile-missing?)
     ;; Return #t if %GUILE-FOR-BUILD is not available yet.
-    (let ((out (derivation-path->output-path (%guile-for-build))))
+    (let ((out (derivation->output-path (%guile-for-build))))
       (not (valid-path? (%store) out))))
 
   (define newest-available-packages
@@ -617,7 +691,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
        (case (version-compare candidate-version current-version)
          ((>) #t)
          ((<) #f)
-         ((=) (let ((candidate-path (derivation-path->output-path
+         ((=) (let ((candidate-path (derivation->output-path
                                      (package-derivation (%store) pkg))))
                 (not (string=? current-path candidate-path))))))
       (#f #f)))
@@ -808,7 +882,7 @@ more information.~%"))
                                  (match tuple
                                    ((name version sub-drv _ (deps ...))
                                     (let ((output-path
-                                           (derivation-path->output-path
+                                           (derivation->output-path
                                             drv sub-drv)))
                                       `(,name ,version ,sub-drv ,output-path
                                               ,(canonicalize-deps deps))))))
@@ -841,12 +915,12 @@ more information.~%"))
           (or dry-run?
               (and (build-derivations (%store) drv)
                    (let* ((prof-drv (profile-derivation (%store) packages))
-                          (prof     (derivation-path->output-path prof-drv))
+                          (prof     (derivation->output-path prof-drv))
                           (old-drv  (profile-derivation
                                      (%store) (manifest-packages
                                                (profile-manifest profile))))
-                          (old-prof (derivation-path->output-path old-drv))
-                          (number   (profile-number profile))
+                          (old-prof (derivation->output-path old-drv))
+                          (number   (generation-number profile))
 
                           ;; Always use NUMBER + 1 for the new profile,
                           ;; possibly overwriting a "previous future
@@ -879,6 +953,40 @@ more information.~%"))
     ;; actually processed, #f otherwise.
     (let ((profile  (assoc-ref opts 'profile)))
       (match (assoc-ref opts 'query)
+        (('list-generations pattern)
+         (define (list-generation number)
+           (begin
+             (format #t (_ "Generation ~a\t~a~%") number
+                     (date->string
+                      (time-utc->date
+                       (generation-time profile number))
+                      "~b ~d ~Y ~T"))
+             (for-each (match-lambda
+                        ((name version output location _)
+                         (format #t "  ~a\t~a\t~a\t~a~%"
+                                 name version output location)))
+
+                       ;; Show most recently installed packages last.
+                       (reverse
+                        (manifest-packages
+                         (profile-manifest
+                          (format #f "~a-~a-link" profile number)))))
+             (newline)))
+
+         (cond ((not (file-exists? profile)) ; XXX: race condition
+                (leave (_ "profile '~a' does not exist~%")
+                       profile))
+               ((string-null? pattern)
+                (for-each list-generation
+                          (generation-numbers profile)))
+               ((matching-generations pattern profile)
+                =>
+                (cut for-each list-generation <>))
+               (else
+                (leave (_ "invalid syntax: ~a~%")
+                       pattern)))
+         #t)
+
         (('list-installed regexp)
          (let* ((regexp    (and regexp (make-regexp regexp)))
                 (manifest  (profile-manifest profile))
@@ -889,7 +997,9 @@ more information.~%"))
                                  (regexp-exec regexp name))
                          (format #t "~a\t~a\t~a\t~a~%"
                                  name (or version "?") output path))))
-                     installed)
+
+                     ;; Show most recently installed packages last.
+                     (reverse installed))
            #t))
 
         (('list-available regexp)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index adcaa49721..023b83e6a3 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -29,7 +29,6 @@
   #:use-module (gnu packages compression)
   #:use-module (gnu packages gnupg)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-37)
   #:export (guix-pull))
 
@@ -198,13 +197,9 @@ Download and deploy the latest version of Guix.\n"))
                         (if (assoc-ref opts 'verbose?)
                             (current-error-port)
                             (%make-void-port "w"))))
-          (let*-values (((config-dir)
-                         (config-directory))
-                        ((source drv)
-                         (unpack store tarball))
-                        ((source-dir)
-                         (derivation-output-path
-                          (assoc-ref (derivation-outputs drv) "out"))))
+          (let* ((config-dir (config-directory))
+                 (source     (unpack store tarball))
+                 (source-dir (derivation->output-path source)))
             (if (show-what-to-build store (list source))
                 (if (build-derivations store (list source))
                     (let ((latest (string-append config-dir "/latest")))
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 63f0c4f8d2..1afc93bbc9 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -446,6 +446,30 @@ PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
 
 
 ;;;
+;;; Help.
+;;;
+
+(define (show-help)
+  (display (_ "Usage: guix substitute-binary [OPTION]...
+Internal tool to substitute a pre-built binary to a local build.\n"))
+  (display (_ "
+      --query            report on the availability of substitutes for the
+                         store file names passed on the standard input"))
+  (display (_ "
+      --substitute STORE-FILE DESTINATION
+                         download STORE-FILE and store it as a Nar in file
+                         DESTINATION"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+
+
+;;;
 ;;; Entry point.
 ;;;
 
@@ -536,7 +560,11 @@ PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
           (restore-file input destination)
           (every (compose zero? cdr waitpid) pids))))
      (("--version")
-      (show-version-and-exit "guix substitute-binary")))))
+      (show-version-and-exit "guix substitute-binary"))
+     (("--help")
+      (show-help))
+     (opts
+      (leave (_ "~a: unrecognized options~%") opts)))))
 
 
 ;;; Local Variables: