#:use-module (guix utils)
#:use-module (guix config)
#: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 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
all of PACKAGES, a list of name/version/output/path/deps tuples."
+ (define packages*
+ ;; Turn any package object in PACKAGES into its output path.
+ (map (match-lambda
+ ((name version output path (deps ...))
+ `(,name ,version ,output ,path
+ ,(map input->name+path deps))))
+ packages))
+
(define builder
`(begin
(use-modules (ice-9 pretty-print)
(call-with-output-file (string-append output "/manifest")
(lambda (p)
(pretty-print '(manifest (version 1)
- (packages ,packages))
+ (packages ,packages*))
p))))))
+ (define ensure-valid-input
+ ;; If a package object appears in the given input, turn it into a
+ ;; derivation path.
+ (match-lambda
+ ((name (? package? p) sub-drv ...)
+ `(,name ,(package-derivation (%store) p) ,@sub-drv))
+ (input
+ input)))
+
(build-expression->derivation store "user-environment"
(%current-system)
builder
(append-map (match-lambda
((name version output path deps)
`((,name ,path)
- ,@deps)))
+ ,@(map ensure-valid-input
+ deps))))
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."
"Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
(let loop ((input input))
(match input
- ((name package)
+ ((name (? package? package))
(loop `(,name ,package "out")))
- ((name package sub-drv)
- (let*-values (((_ drv)
- (package-derivation (%store) package))
- ((out)
- (derivation-output-path
- (assoc-ref (derivation-outputs drv) sub-drv))))
- `(,name ,out))))))
+ ((name (? package? package) sub-drv)
+ `(,name ,(package-output (%store) package sub-drv)))
+ (_
+ input))))
(define %sigint-prompt
;; The prompt to jump to upon SIGINT.
(lambda (signum)
(sigaction SIGINT SIG_DFL)
(abort-to-prompt %sigint-prompt signum)))
- (thunk))
+ (dynamic-wind
+ (const #t)
+ thunk
+ (cut sigaction SIGINT SIG_DFL)))
(lambda (k signum)
(handler signum))))
(force-output (current-error-port))
(call-with-sigint-handler
(lambda ()
- (let ((result exp))
- ;; Clear the line.
- (display #\cr (current-error-port))
- (display blank (current-error-port))
- (display #\cr (current-error-port))
- (force-output (current-error-port))
- exp))
+ (dynamic-wind
+ (const #f)
+ (lambda () exp)
+ (lambda ()
+ ;; Clear the line.
+ (display #\cr (current-error-port))
+ (display blank (current-error-port))
+ (display #\cr (current-error-port))
+ (force-output (current-error-port)))))
(lambda (signum)
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f))))
+(define ftp-open*
+ ;; Memoizing version of `ftp-open'. The goal is to avoid initiating a new
+ ;; FTP connection for each package, esp. since most of them are to the same
+ ;; server. This has a noticeable impact when doing "guix upgrade -u".
+ (memoize ftp-open))
+
(define (check-package-freshness package)
"Check whether PACKAGE has a newer version available upstream, and report
it."
(when (false-if-exception (gnu-package? package))
(let ((name (package-name package))
(full-name (package-full-name package)))
- (match (waiting (latest-release name)
+ (match (waiting (latest-release name
+ #:ftp-open ftp-open*
+ #:ftp-close (const #f))
(_ "looking for the latest release of GNU ~a...") name)
((latest-version . _)
(when (version>? latest-version full-name)
(define %default-options
;; Alist of default option values.
`((profile . ,%current-profile)
+ (max-silent-time . 3600)
(substitutes? . #t)))
(define (show-help)
--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"))
(display (_ "
-n, --dry-run show what would be done without actually doing it"))
+ (display (_ "
+ --fallback fall back to building when the substituter fails"))
(display (_ "
--no-substitutes build instead of resorting to pre-built substitutes"))
+ (display (_ "
+ --max-silent-time=SECONDS
+ mark the build as failed after SECONDS of silence"))
(display (_ "
--bootstrap use the bootstrap Guile to build the profile"))
(display (_ "
(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)))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
(alist-cons 'dry-run? #t result)))
+ (option '("fallback") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'fallback? #t
+ (alist-delete 'fallback? result))))
(option '("no-substitutes") #f #f
(lambda (opt name arg result)
(alist-cons 'substitutes? #f
(alist-delete 'substitutes? result))))
+ (option '("max-silent-time") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'max-silent-time (string->number* arg)
+ result)))
(option '("bootstrap") #f #f
(lambda (opt name arg result)
(alist-cons 'bootstrap? #t 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)))
(define (ensure-default-profile)
- ;; Ensure the default profile symlink and directory exist.
+ ;; Ensure the default profile symlink and directory exist and are
+ ;; writable.
+
+ (define (rtfm)
+ (format (current-error-port)
+ (_ "Try \"info '(guix) Invoking guix package'\" for \
+more information.~%"))
+ (exit 1))
;; Create ~/.guix-profile if it doesn't exist yet.
(when (and %user-environment-directory
(lstat %user-environment-directory))))
(symlink %current-profile %user-environment-directory))
- ;; Attempt to create /…/profiles/per-user/$USER if needed.
- (unless (directory-exists? %profile-directory)
- (catch 'system-error
- (lambda ()
- (mkdir-p %profile-directory))
- (lambda args
- ;; Often, we cannot create %PROFILE-DIRECTORY because its
- ;; parent directory is root-owned and we're running
- ;; unprivileged.
- (format (current-error-port)
- (_ "error: while creating directory `~a': ~a~%")
- %profile-directory
- (strerror (system-error-errno args)))
- (format (current-error-port)
- (_ "Please create the `~a' directory, with you as the owner.~%")
- %profile-directory)
- (exit 1)))))
+ (let ((s (stat %profile-directory #f)))
+ ;; Attempt to create /…/profiles/per-user/$USER if needed.
+ (unless (and s (eq? 'directory (stat:type s)))
+ (catch 'system-error
+ (lambda ()
+ (mkdir-p %profile-directory))
+ (lambda args
+ ;; Often, we cannot create %PROFILE-DIRECTORY because its
+ ;; parent directory is root-owned and we're running
+ ;; unprivileged.
+ (format (current-error-port)
+ (_ "error: while creating directory `~a': ~a~%")
+ %profile-directory
+ (strerror (system-error-errno args)))
+ (format (current-error-port)
+ (_ "Please create the `~a' directory, with you as the owner.~%")
+ %profile-directory)
+ (rtfm))))
+
+ ;; Bail out if it's not owned by the user.
+ (unless (or (not s) (= (stat:uid s) (getuid)))
+ (format (current-error-port)
+ (_ "error: directory `~a' is not owned by you~%")
+ %profile-directory)
+ (format (current-error-port)
+ (_ "Please change the owner of `~a' to user ~s.~%")
+ %profile-directory (or (getenv "USER") (getuid)))
+ (rtfm))))
(define (process-actions opts)
;; Process any install/remove/upgrade action from OPTS.
;; where each input is a name/path tuple.
(define (same? d1 d2)
(match d1
- ((_ path1)
+ ((_ p1)
+ (match d2
+ ((_ p2) (eq? p1 p2))
+ (_ #f)))
+ ((_ p1 out1)
(match d2
- ((_ path2)
- (string=? path1 path2))))))
+ ((_ p2 out2)
+ (and (string=? out1 out2)
+ (eq? p1 p2)))
+ (_ #f)))))
+
+ (delete-duplicates deps same?))
- (delete-duplicates (map input->name+path 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)
- (let ((path (package-derivation (%store) p))
- (deps (package-transitive-propagated-inputs p)))
+ ;; Convert package P to a tuple.
+ ;; When given a package via `-e', install the first of its
+ ;; outputs (XXX).
+ (let* ((out (car (package-outputs p)))
+ (path (package-output (%store) p out))
+ (deps (package-transitive-propagated-inputs p)))
`(,(package-name p)
,(package-version p)
-
- ;; When given a package via `-e', install the first of its
- ;; outputs (XXX).
- ,(car (package-outputs p))
-
- ,path
+ ,out
+ ,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
(current-error-port)
(%make-void-port "w"))))
(build-derivations (%store) (list prof-drv)))
- (begin
+ (let ((count (length packages)))
(switch-symlinks name prof)
(switch-symlinks profile name)
+ (format #t (N_ "~a package in profile~%"
+ "~a packages in profile~%"
+ count)
+ count)
(display-search-paths packages
profile))))))))))
;; 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)
(with-error-handling
(parameterize ((%store (open-connection)))
(set-build-options (%store)
+ #:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes?
- (assoc-ref opts 'substitutes?))
+ (assoc-ref opts 'substitutes?)
+ #:max-silent-time
+ (assoc-ref opts 'max-silent-time))
(parameterize ((%guile-for-build
(package-derivation (%store)
HCoop / jackhill / guix / guix.git / blobdiff