9241172c9d
* guix-package.in (profile-numbers): New procedure. (latest-profile-number): Use it. (previous-profile-number): New procedure. (roll-back): Use it lieu of `1-'. Check whether PREVIOUS-NUMBER is zero, and raise an error when it is. * tests/guix-package.sh: Test whether we can roll back over a "hole".
568 lines
23 KiB
Scheme
568 lines
23 KiB
Scheme
#!/bin/sh
|
||
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||
|
||
prefix="@prefix@"
|
||
datarootdir="@datarootdir@"
|
||
|
||
GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
|
||
export GUILE_LOAD_COMPILED_PATH
|
||
|
||
main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')'
|
||
exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
|
||
-c "(apply $main (cdr (command-line)))" "$@"
|
||
!#
|
||
;;; 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.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (guix-package)
|
||
#:use-module (guix ui)
|
||
#:use-module (guix store)
|
||
#:use-module (guix derivations)
|
||
#: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 (ice-9 regex)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-11)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (srfi srfi-34)
|
||
#:use-module (srfi srfi-37)
|
||
#:use-module (distro)
|
||
#:use-module ((distro packages base) #:select (guile-final))
|
||
#:use-module ((distro packages bootstrap) #:select (%bootstrap-guile))
|
||
#:export (guix-package))
|
||
|
||
(define %store
|
||
(make-parameter #f))
|
||
|
||
|
||
;;;
|
||
;;; User environment.
|
||
;;;
|
||
|
||
(define %user-environment-directory
|
||
(and=> (getenv "HOME")
|
||
(cut string-append <> "/.guix-profile")))
|
||
|
||
(define %profile-directory
|
||
(string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/"
|
||
(or (and=> (getenv "USER")
|
||
(cut string-append "per-user/" <>))
|
||
"default")))
|
||
|
||
(define %current-profile
|
||
;; Call it `guix-profile', not `profile', to allow Guix profiles to
|
||
;; coexist with Nix profiles.
|
||
(string-append %profile-directory "/guix-profile"))
|
||
|
||
(define (profile-manifest profile)
|
||
"Return the PROFILE's manifest."
|
||
(let ((manifest (string-append profile "/manifest")))
|
||
(if (file-exists? manifest)
|
||
(call-with-input-file manifest read)
|
||
'(manifest (version 0) (packages ())))))
|
||
|
||
(define (manifest-packages manifest)
|
||
"Return the packages listed in MANIFEST."
|
||
(match manifest
|
||
(('manifest ('version 0) ('packages packages))
|
||
packages)
|
||
(_
|
||
(error "unsupported manifest format" manifest))))
|
||
|
||
(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.
|
||
(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
|
||
(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
|
||
all of PACKAGES, a list of name/version/output/path tuples."
|
||
(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 user environment `~a' with ~a packages...~%"
|
||
output (length inputs))
|
||
(union-build output inputs)
|
||
(call-with-output-file (string-append output "/manifest")
|
||
(lambda (p)
|
||
(pretty-print '(manifest (version 0)
|
||
(packages ,packages))
|
||
p))))))
|
||
|
||
(build-expression->derivation store "user-environment"
|
||
(%current-system)
|
||
builder
|
||
(map (match-lambda
|
||
((name version output path)
|
||
`(,name ,path)))
|
||
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)))))
|
||
|
||
|
||
;;;
|
||
;;; Command-line options.
|
||
;;;
|
||
|
||
(define %default-options
|
||
;; Alist of default option values.
|
||
`((profile . ,%current-profile)))
|
||
|
||
(define (show-help)
|
||
(display (_ "Usage: guix-package [OPTION]... PACKAGES...
|
||
Install, remove, or upgrade PACKAGES in a single transaction.\n"))
|
||
(display (_ "
|
||
-i, --install=PACKAGE install PACKAGE"))
|
||
(display (_ "
|
||
-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 (_ "
|
||
--bootstrap use the bootstrap Guile to build the profile"))
|
||
(display (_ "
|
||
--verbose produce verbose output"))
|
||
(newline)
|
||
(display (_ "
|
||
-I, --list-installed[=REGEXP]
|
||
list installed packages matching REGEXP"))
|
||
(display (_ "
|
||
-A, --list-available[=REGEXP]
|
||
list available packages matching REGEXP"))
|
||
(newline)
|
||
(display (_ "
|
||
-h, --help display this help and exit"))
|
||
(display (_ "
|
||
-V, --version display version information and exit"))
|
||
(newline)
|
||
(show-bug-report-information))
|
||
|
||
(define %options
|
||
;; Specification of the command-line options.
|
||
(list (option '(#\h "help") #f #f
|
||
(lambda args
|
||
(show-help)
|
||
(exit 0)))
|
||
(option '(#\V "version") #f #f
|
||
(lambda args
|
||
(show-version-and-exit "guix-package")))
|
||
|
||
(option '(#\i "install") #t #f
|
||
(lambda (opt name arg result)
|
||
(alist-cons 'install arg result)))
|
||
(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
|
||
(alist-delete 'profile result))))
|
||
(option '(#\n "dry-run") #f #f
|
||
(lambda (opt name arg result)
|
||
(alist-cons 'dry-run? #t result)))
|
||
(option '("bootstrap") #f #f
|
||
(lambda (opt name arg result)
|
||
(alist-cons 'bootstrap? #t result)))
|
||
(option '("verbose") #f #f
|
||
(lambda (opt name arg result)
|
||
(alist-cons 'verbose? #t result)))
|
||
(option '(#\I "list-installed") #f #t
|
||
(lambda (opt name arg result)
|
||
(cons `(query list-installed ,(or arg ""))
|
||
result)))
|
||
(option '(#\A "list-available") #f #t
|
||
(lambda (opt name arg result)
|
||
(cons `(query list-available ,(or arg ""))
|
||
result)))))
|
||
|
||
|
||
;;;
|
||
;;; Entry point.
|
||
;;;
|
||
|
||
(define (guix-package . args)
|
||
(define (parse-options)
|
||
;; Return the alist of option values.
|
||
(args-fold args %options
|
||
(lambda (opt name arg result)
|
||
(leave (_ "~A: unrecognized option~%") name))
|
||
(lambda (arg result)
|
||
(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)))
|
||
drv))
|
||
(req* (delete-duplicates
|
||
(append (remove (compose (cute valid-path? (%store) <>)
|
||
derivation-path->output-path)
|
||
drv)
|
||
(map derivation-input-path req)))))
|
||
(if dry-run?
|
||
(format (current-error-port)
|
||
(N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
|
||
"~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
|
||
(length req*))
|
||
(null? req*) req*)
|
||
(format (current-error-port)
|
||
(N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
|
||
"~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
|
||
(length req*))
|
||
(null? req*) req*))))
|
||
|
||
(define (find-package name)
|
||
;; Find the package NAME; NAME may contain a version number and a
|
||
;; sub-derivation name.
|
||
(define request name)
|
||
|
||
(let*-values (((name sub-drv)
|
||
(match (string-rindex name #\:)
|
||
(#f (values name "out"))
|
||
(colon (values (substring name 0 colon)
|
||
(substring name (+ 1 colon))))))
|
||
((name version)
|
||
(package-name->name+version name)))
|
||
(match (find-packages-by-name name version)
|
||
((p)
|
||
(list name (package-version p) sub-drv p))
|
||
((p p* ...)
|
||
(format (current-error-port)
|
||
(_ "warning: ambiguous package specification `~a'~%")
|
||
request)
|
||
(format (current-error-port)
|
||
(_ "warning: choosing ~a from ~a~%")
|
||
(package-full-name p)
|
||
(location->string (package-location p)))
|
||
(list name (package-version p) sub-drv p))
|
||
(()
|
||
(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.
|
||
|
||
(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
|
||
;; actually processed, #f otherwise.
|
||
(let ((profile (assoc-ref opts 'profile)))
|
||
(match (assoc-ref opts 'query)
|
||
(('list-installed regexp)
|
||
(let* ((regexp (and regexp (make-regexp regexp)))
|
||
(manifest (profile-manifest profile))
|
||
(installed (manifest-packages manifest)))
|
||
(for-each (match-lambda
|
||
((name version output path)
|
||
(when (or (not regexp)
|
||
(regexp-exec regexp name))
|
||
(format #t "~a\t~a\t~a\t~a~%"
|
||
name (or version "?") output path))))
|
||
installed)
|
||
#t))
|
||
(('list-available regexp)
|
||
(let* ((regexp (and regexp (make-regexp regexp)))
|
||
(available (fold-packages
|
||
(lambda (p r)
|
||
(let ((n (package-name p)))
|
||
(if regexp
|
||
(if (regexp-exec regexp n)
|
||
(cons p r)
|
||
r)
|
||
(cons p r))))
|
||
'())))
|
||
(for-each (lambda (p)
|
||
(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)
|
||
(string<? (package-name p1)
|
||
(package-name p2)))))
|
||
#t))
|
||
(_ #f))))
|
||
|
||
(setlocale LC_ALL "")
|
||
(textdomain "guix")
|
||
(setvbuf (current-output-port) _IOLBF)
|
||
(setvbuf (current-error-port) _IOLBF)
|
||
|
||
(let ((opts (parse-options)))
|
||
(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)))))))
|