!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (guix config)
+ #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
#:use-module (ice-9 ftw)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
- #:use-module (distro)
- #:use-module (distro packages guile)
+ #:use-module (gnu packages)
+ #:use-module ((gnu packages base) #:select (guile-final))
+ #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
#:export (guix-package))
(define %store
- (open-connection))
+ (make-parameter #f))
\f
;;;
(cut string-append <> "/.guix-profile")))
(define %profile-directory
- (string-append %state-directory "/profiles/"
+ (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/"
(or (and=> (getenv "USER")
(cut string-append "per-user/" <>))
"default")))
(_
(error "unsupported manifest format" manifest))))
-(define (latest-profile-number profile)
- "Return the identifying number of the latest generation of PROFILE.
-PROFILE is the name of the symlink to the current generation."
- (define %profile-rx
- (make-regexp (string-append "^" (regexp-quote (basename profile))
- "-([0-9]+)")))
+(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 (profile-numbers profile)
+ "Return the 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.
(sort files entry<?))))
(match (scandir (dirname profile)
- (cut regexp-exec %profile-rx <>))
+ (cute regexp-exec (profile-regexp profile) <>))
(#f ; no profile directory
- 0)
+ '(0))
(() ; no profiles
- 0)
+ '(0))
((profiles ...) ; former profiles around
- (let ((numbers (map (compose string->number
- (cut match:substring <> 1)
- (cut regexp-exec %profile-rx <>))
- profiles)))
- (fold (lambda (number highest)
- (if (> number highest)
- number
- highest))
- 0
- numbers)))))
+ (map (compose string->number
+ (cut match:substring <> 1)
+ (cute regexp-exec (profile-regexp profile) <>))
+ profiles))))
+
+(define (latest-profile-number profile)
+ "Return the identifying number of the latest generation of PROFILE.
+PROFILE is the name of the symlink to the current generation."
+ (fold (lambda (number highest)
+ (if (> number highest)
+ number
+ highest))
+ 0
+ (profile-numbers profile)))
+
+(define (previous-profile-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
+ (profile-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)
+ "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 (roll-back profile)
+ "Roll back to the previous generation of PROFILE."
+ ;; XXX: Get the previous generation number from the manifest?
+ (let* ((number (profile-number profile))
+ (previous-number (previous-profile-number profile number))
+ (previous-profile (format #f "~a/~a-~a-link"
+ (dirname profile) profile
+ previous-number))
+ (manifest (string-append previous-profile "/manifest")))
+
+ (define (switch-link)
+ ;; Atomically switch PROFILE to the previous profile.
+ (let ((pivot (string-append previous-profile ".new")))
+ (format #t (_ "switching from generation ~a to ~a~%")
+ number previous-number)
+ (symlink previous-profile pivot)
+ (rename-file pivot profile)))
+
+ (cond ((zero? number)
+ (format (current-error-port)
+ (_ "error: `~a' is not a valid profile~%")
+ profile))
+ ((or (zero? previous-number)
+ (not (file-exists? previous-profile)))
+ (leave (_ "error: no previous profile; not rolling back~%")))
+ (else (switch-link)))))
+
\f
;;;
;;; Command-line options.
-r, --remove=PACKAGE remove PACKAGE"))
(display (_ "
-u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP"))
+ (display (_ "
+ --roll-back roll back to the previous generation"))
(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 (_ "
- -b, --bootstrap use the bootstrap Guile to build the profile"))
+ --bootstrap use the bootstrap Guile to build the profile"))
(display (_ "
--verbose produce verbose output"))
(newline)
(option '(#\r "remove") #t #f
(lambda (opt name arg result)
(alist-cons 'remove arg result)))
+ (option '("roll-back") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'roll-back? #t result)))
(option '(#\p "profile") #t #f
(lambda (opt name arg result)
(alist-cons 'profile arg
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
(alist-cons 'dry-run? #t result)))
- (option '(#\b "bootstrap") #f #f
+ (option '("bootstrap") #f #f
(lambda (opt name arg result)
(alist-cons 'bootstrap? #t result)))
(option '("verbose") #f #f
(alist-cons 'argument arg result))
%default-options))
+ (define (guile-missing?)
+ ;; Return #t if %GUILE-FOR-BUILD is not available yet.
+ (let ((out (derivation-path->output-path (%guile-for-build))))
+ (not (valid-path? (%store) out))))
+
(define (show-what-to-build drv dry-run?)
;; Show what will/would be built in realizing the derivations listed
;; in DRV.
(let* ((req (append-map (lambda (drv-path)
(let ((d (call-with-input-file drv-path
read-derivation)))
- (derivation-prerequisites-to-build %store d)))
+ (derivation-prerequisites-to-build
+ (%store) d)))
drv))
(req* (delete-duplicates
- (append (remove (compose (cut valid-path? %store <>)
+ (append (remove (compose (cute valid-path? (%store) <>)
derivation-path->output-path)
drv)
(map derivation-input-path req)))))
(()
(leave (_ "~a: package not found~%") request)))))
+ (define (ensure-default-profile)
+ ;; Ensure the default profile symlink and directory exist.
+
+ ;; Create ~/.guix-profile if it doesn't exist yet.
+ (when (and %user-environment-directory
+ %current-profile
+ (not (false-if-exception
+ (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)))))
+
(define (process-actions opts)
;; Process any install/remove/upgrade action from OPTS.
- (let* ((dry-run? (assoc-ref opts 'dry-run?))
- (verbose? (assoc-ref opts 'verbose?))
- (profile (assoc-ref opts 'profile))
- (install (filter-map (match-lambda
- (('install . (? store-path?))
- #f)
- (('install . package)
- (find-package package))
- (_ #f))
- opts))
- (drv (filter-map (match-lambda
- ((name version sub-drv
- (? package? package))
- (package-derivation %store package))
- (_ #f))
- install))
- (install* (append
- (filter-map (match-lambda
- (('install . (? store-path? path))
- (let-values (((name version)
- (package-name->name+version
- (store-path-package-name
- path))))
- `(,name ,version #f ,path)))
- (_ #f))
- opts)
- (map (lambda (tuple drv)
- (match tuple
- ((name version sub-drv _)
- (let ((output-path
- (derivation-path->output-path
- drv sub-drv)))
- `(,name ,version ,sub-drv ,output-path)))))
- install drv)))
- (remove (filter-map (match-lambda
- (('remove . package)
- package)
- (_ #f))
- opts))
- (packages (append install*
- (fold (lambda (package result)
- (match package
- ((name _ ...)
- (alist-delete name result))))
- (fold alist-delete
- (manifest-packages
- (profile-manifest profile))
- remove)
- install*))))
-
- (show-what-to-build drv dry-run?)
-
- (or dry-run?
- (and (build-derivations %store drv)
- (let* ((prof-drv (profile-derivation %store packages))
- (prof (derivation-path->output-path prof-drv))
- (old-drv (profile-derivation
- %store (manifest-packages
- (profile-manifest profile))))
- (old-prof (derivation-path->output-path old-drv))
- (number (latest-profile-number profile))
- (name (format #f "~a/~a-~a-link"
- (dirname profile)
- (basename profile) (+ 1 number))))
- (if (string=? old-prof prof)
- (format (current-error-port) (_ "nothing to be done~%"))
- (and (parameterize ((current-build-output-port
- (if verbose?
- (current-error-port)
- (%make-void-port "w"))))
- (build-derivations %store (list prof-drv)))
- (begin
- (symlink prof name)
- (when (file-exists? profile)
- (delete-file profile))
- (symlink name profile)))))))))
+
+ (define dry-run? (assoc-ref opts 'dry-run?))
+ (define verbose? (assoc-ref opts 'verbose?))
+ (define profile (assoc-ref opts 'profile))
+
+ ;; First roll back if asked to.
+ (if (and (assoc-ref opts 'roll-back?) (not dry-run?))
+ (begin
+ (roll-back profile)
+ (process-actions (alist-delete 'roll-back? opts)))
+ (let* ((install (filter-map (match-lambda
+ (('install . (? store-path?))
+ #f)
+ (('install . package)
+ (find-package package))
+ (_ #f))
+ opts))
+ (drv (filter-map (match-lambda
+ ((name version sub-drv
+ (? package? package))
+ (package-derivation (%store) package))
+ (_ #f))
+ install))
+ (install* (append
+ (filter-map (match-lambda
+ (('install . (? store-path? path))
+ (let-values (((name version)
+ (package-name->name+version
+ (store-path-package-name
+ path))))
+ `(,name ,version #f ,path)))
+ (_ #f))
+ opts)
+ (map (lambda (tuple drv)
+ (match tuple
+ ((name version sub-drv _)
+ (let ((output-path
+ (derivation-path->output-path
+ drv sub-drv)))
+ `(,name ,version ,sub-drv ,output-path)))))
+ install drv)))
+ (remove (filter-map (match-lambda
+ (('remove . package)
+ package)
+ (_ #f))
+ opts))
+ (packages (append install*
+ (fold (lambda (package result)
+ (match package
+ ((name _ ...)
+ (alist-delete name result))))
+ (fold alist-delete
+ (manifest-packages
+ (profile-manifest profile))
+ remove)
+ install*))))
+
+ (when (equal? profile %current-profile)
+ (ensure-default-profile))
+
+ (show-what-to-build drv dry-run?)
+
+ (or dry-run?
+ (and (build-derivations (%store) drv)
+ (let* ((prof-drv (profile-derivation (%store) packages))
+ (prof (derivation-path->output-path prof-drv))
+ (old-drv (profile-derivation
+ (%store) (manifest-packages
+ (profile-manifest profile))))
+ (old-prof (derivation-path->output-path old-drv))
+ (number (latest-profile-number profile))
+ (name (format #f "~a/~a-~a-link"
+ (dirname profile)
+ (basename profile) (+ 1 number))))
+ (if (string=? old-prof prof)
+ (when (or (pair? install) (pair? remove))
+ (format (current-error-port)
+ (_ "nothing to be done~%")))
+ (and (parameterize ((current-build-output-port
+ ;; Output something when Guile
+ ;; needs to be built.
+ (if (or verbose? (guile-missing?))
+ (current-error-port)
+ (%make-void-port "w"))))
+ (build-derivations (%store) (list prof-drv)))
+ (begin
+ (symlink prof name)
+ (when (file-exists? profile)
+ (delete-file profile))
+ (symlink name profile))))))))))
(define (process-query opts)
;; Process any query specified by OPTS. Return #t when a query was
(cons p r))))
'())))
(for-each (lambda (p)
- (format #t "~a\t~a\t~a~%"
+ (format #t "~a\t~a\t~a\t~a~%"
(package-name p)
(package-version p)
+ (string-join (package-outputs p) ",")
(location->string (package-location p))))
(sort available
(lambda (p1 p2)
(setvbuf (current-error-port) _IOLBF)
(let ((opts (parse-options)))
- (with-error-handling
- (or (process-query opts)
- (parameterize ((%guile-for-build
- (package-derivation %store
- (if (assoc-ref opts 'bootstrap?)
- (@@ (distro packages base)
- %bootstrap-guile)
- guile-2.0))))
- (process-actions opts))))))
-
-;; Local Variables:
-;; eval: (put 'guard 'scheme-indent-function 1)
-;; End:
+ (parameterize ((%store (open-connection)))
+ (with-error-handling
+ (or (process-query opts)
+ (parameterize ((%guile-for-build
+ (package-derivation (%store)
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ guile-final))))
+ (process-actions opts)))))))
HCoop / jackhill / guix / guix.git / blobdiff