#: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)
(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<?)))
(() ; 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\")."
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
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))))
(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~%")
(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."
--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"))
(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)))
(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
(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)))
(delete-duplicates deps same?))
+ (define (same-package? tuple name out)
+ (match tuple
+ ((tuple-name _ tuple-output _ ...)
+ (and (equal? name tuple-name)
+ (equal? out tuple-output)))))
+
(define (package->tuple p)
;; Convert package P to a tuple.
;; When given a package via `-e', install the first of its
`(,(package-name p)
,(package-version p)
,out
- ,path
+ ,p
,(canonicalize-deps deps))))
(define (show-what-to-remove/install remove install dry-run?)
upgrade
(filter-map (match-lambda
(('install . (? package? p))
- #f)
+ (package->tuple p))
(('install . (? store-path?))
#f)
(('install . package)
(install* (append
(filter-map (match-lambda
(('install . (? package? p))
- (package->tuple p))
+ #f)
(('install . (? store-path? path))
(let-values (((name version)
(package-name->name+version
(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))))))
(packages (append install*
(fold (lambda (package result)
(match package
- ((name _ ...)
- (alist-delete name result))))
+ ((name _ out _ ...)
+ (filter (negate
+ (cut same-package? <>
+ name out))
+ result))))
(fold alist-delete installed remove)
install*))))
(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
;; 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)
+ (let ((numbers (generation-numbers profile)))
+ (if (equal? numbers '(0))
+ (exit 1)
+ (for-each list-generation numbers))))
+ ((matching-generations pattern profile)
+ =>
+ (lambda (numbers)
+ (if (null-list? numbers)
+ (exit 1)
+ (for-each list-generation numbers))))
+ (else
+ (leave (_ "invalid syntax: ~a~%")
+ pattern)))
+ #t)
+
(('list-installed regexp)
(let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile))
(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)
HCoop / jackhill / guix / guix.git / blobdiff