summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2014-08-23 20:43:51 -0400
committerMark H Weaver <mhw@netris.org>2014-08-23 20:43:51 -0400
commitce3e35ed6af5c502029fb79cb5e2bdbca528d841 (patch)
treef2db16e01972bc8dcf5d69e4c94b8c4da52e9547
parentfa5731baabdb4a9240aad2154847f352aed02d6e (diff)
parentf0dafadcfc0336e8d437f39c3563029eaa0f7953 (diff)
downloadpatches-ce3e35ed6af5c502029fb79cb5e2bdbca528d841.tar
patches-ce3e35ed6af5c502029fb79cb5e2bdbca528d841.tar.gz
Merge branch 'master' into core-updates
-rw-r--r--Makefile.am5
-rw-r--r--THANKS1
-rw-r--r--gnu/packages.scm88
-rw-r--r--gnu/packages/bdw-gc.scm4
-rw-r--r--gnu/packages/gnupg.scm4
-rw-r--r--gnu/packages/video.scm4
-rw-r--r--guix/download.scm2
-rw-r--r--guix/git-download.scm79
-rw-r--r--guix/profiles.scm221
-rw-r--r--guix/scripts/package.scm145
-rw-r--r--guix/svn-download.scm58
-rw-r--r--guix/tests.scm70
-rw-r--r--tests/builders.scm9
-rw-r--r--tests/derivations.scm12
-rw-r--r--tests/gexp.scm15
-rw-r--r--tests/monads.scm6
-rw-r--r--tests/nar.scm19
-rw-r--r--tests/packages.scm9
-rw-r--r--tests/profiles.scm35
-rw-r--r--tests/store.scm14
-rw-r--r--tests/union.scm9
21 files changed, 486 insertions, 323 deletions
diff --git a/Makefile.am b/Makefile.am
index 17a676ac54..fff5958355 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -99,6 +99,9 @@ MODULES += \
endif BUILD_DAEMON_OFFLOAD
+# Internal module with test suite support.
+noinst_DATA = guix/tests.scm
+
# Because of the autoload hack in (guix build download), we must build it
# first to avoid errors on systems where (gnutls) is unavailable.
guix/scripts/download.go: guix/build/download.go
@@ -113,7 +116,7 @@ KCONFIGS = \
EXAMPLES = \
gnu/system/os-config.tmpl
-GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go
+GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go guix/tests.go
nobase_dist_guilemodule_DATA = $(MODULES) $(KCONFIGS) $(EXAMPLES)
nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm
diff --git a/THANKS b/THANKS
index 95427f9bee..d15cafa987 100644
--- a/THANKS
+++ b/THANKS
@@ -16,6 +16,7 @@ infrastructure help:
John Darrington <jmd@gnu.org>
Rafael Ferreira <rafael.f.f1@gmail.com>
Christian Grothoff <christian@grothoff.org>
+ Brandon Invergo <brandon@gnu.org>
Jeffrin Jose <ahiliation@yahoo.co.in>
Kete <kete@ninthfloor.org>
Alex Kost <alezost@gmail.com>
diff --git a/gnu/packages.scm b/gnu/packages.scm
index 77d9d3ee82..14ad75561c 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -22,6 +22,8 @@
#:use-module (guix packages)
#:use-module (guix ui)
#:use-module (guix utils)
+ #:use-module ((guix ftp-client) #:select (ftp-open))
+ #:use-module (guix gnu-maintenance)
#:use-module (ice-9 ftw)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
@@ -41,7 +43,9 @@
package-direct-dependents
package-transitive-dependents
- package-covering-dependents))
+ package-covering-dependents
+
+ check-package-freshness))
;;; Commentary:
;;;
@@ -50,8 +54,6 @@
;;;
;;; Code:
-(define _ (cut gettext <> "guix"))
-
;; By default, we store patches and bootstrap binaries alongside Guile
;; modules. This is so that these extra files can be found without
;; requiring a special setup, such as a specific installation directory
@@ -60,7 +62,7 @@
(define %patch-path
(make-parameter
- (map (cut string-append <> "/gnu/packages/patches")
+ (map (cut string-append <> "/gnu/packages/patches")
%load-path)))
(define %bootstrap-binaries-path
@@ -246,3 +248,81 @@ include all of PACKAGES and all packages that depend on PACKAGES."
(lambda (node) (vhash-refq dependency-dag node))
;; Start with the dependents to avoid including PACKAGES in the result.
(package-direct-dependents packages))))
+
+
+(define %sigint-prompt
+ ;; The prompt to jump to upon SIGINT.
+ (make-prompt-tag "interruptible"))
+
+(define (call-with-sigint-handler thunk handler)
+ "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal
+number in the context of the continuation of the call to this function, and
+return its return value."
+ (call-with-prompt %sigint-prompt
+ (lambda ()
+ (sigaction SIGINT
+ (lambda (signum)
+ (sigaction SIGINT SIG_DFL)
+ (abort-to-prompt %sigint-prompt signum)))
+ (dynamic-wind
+ (const #t)
+ thunk
+ (cut sigaction SIGINT SIG_DFL)))
+ (lambda (k signum)
+ (handler signum))))
+
+(define-syntax-rule (waiting exp fmt rest ...)
+ "Display the given message while EXP is being evaluated."
+ (let* ((message (format #f fmt rest ...))
+ (blank (make-string (string-length message) #\space)))
+ (display message (current-error-port))
+ (force-output (current-error-port))
+ (call-with-sigint-handler
+ (lambda ()
+ (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."
+ ;; TODO: Automatically inject the upstream version when desired.
+
+ (catch #t
+ (lambda ()
+ (when (false-if-exception (gnu-package? package))
+ (let ((name (package-name package))
+ (full-name (package-full-name package)))
+ (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)
+ (format (current-error-port)
+ (_ "~a: note: using ~a \
+but ~a is available upstream~%")
+ (location->string (package-location package))
+ full-name latest-version)))
+ (_ #t)))))
+ (lambda (key . args)
+ ;; Silently ignore networking errors rather than preventing
+ ;; installation.
+ (case key
+ ((getaddrinfo-error ftp-error) #f)
+ (else (apply throw key args))))))
diff --git a/gnu/packages/bdw-gc.scm b/gnu/packages/bdw-gc.scm
index df7cd1b489..66158912d7 100644
--- a/gnu/packages/bdw-gc.scm
+++ b/gnu/packages/bdw-gc.scm
@@ -27,14 +27,14 @@
(define-public libgc-7.2
(package
(name "libgc")
- (version "7.2e")
+ (version "7.2f")
(source (origin
(method url-fetch)
(uri (string-append "http://www.hboehm.info/gc/gc_source/gc-"
version ".tar.gz"))
(sha256
(base32
- "0jxgr71rhk58dzc1ihqs51vldh2qs1m154bn41qh6q1dm145nc89"))))
+ "119x7p1cqw40mpwj80xfq879l9m1dkc7vbc1f3bz3kvkf8bf6p16"))))
(build-system gnu-build-system)
(arguments
;; Make it so that we don't rely on /proc. This is especially useful in
diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm
index 384ec6289e..3207c74b0b 100644
--- a/gnu/packages/gnupg.scm
+++ b/gnu/packages/gnupg.scm
@@ -96,7 +96,7 @@ generation.")
(define-public libgcrypt-1.5
(package (inherit libgcrypt)
- (version "1.5.3")
+ (version "1.5.4")
(source
(origin
(method url-fetch)
@@ -104,7 +104,7 @@ generation.")
version ".tar.bz2"))
(sha256
(base32
- "1lar8y3lh61zl5flljpz540d78g99h4d5idfwrfw8lm3gm737xdw"))))))
+ "0czvqxkzd5y872ipy6s010ifwdwv29sqbnqc4pf56sd486gqvy6m"))))))
(define-public libassuan
(package
diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm
index 23c63fabdb..2873c49e3b 100644
--- a/gnu/packages/video.scm
+++ b/gnu/packages/video.scm
@@ -58,14 +58,14 @@
(define-public ffmpeg
(package
(name "ffmpeg")
- (version "2.3.1")
+ (version "2.3.3")
(source (origin
(method url-fetch)
(uri (string-append "http://www.ffmpeg.org/releases/ffmpeg-"
version ".tar.bz2"))
(sha256
(base32
- "10w1sw5c9qjlaqlr77r3znzm7y0y9qpkni0mfr9rhij22562yspf"))))
+ "0ik4c06anh49r5b0d3rq9if4zl6ysjsa341655kzw22fl880sk5v"))))
(build-system gnu-build-system)
(inputs
`(("fontconfig" ,fontconfig)
diff --git a/guix/download.scm b/guix/download.scm
index 22c3ba19ca..92d08fc2bd 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -185,7 +185,7 @@
"http://ftp.debian.org/debian/"))))
(define (gnutls-package)
- "Return the GnuTLS package for SYSTEM."
+ "Return the default GnuTLS package."
(let ((module (resolve-interface '(gnu packages gnutls))))
(module-ref module 'gnutls)))
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 43d190db54..5691e8a870 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -17,8 +17,9 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix git-download)
+ #:use-module (guix gexp)
+ #:use-module (guix monads)
#:use-module (guix records)
- #:use-module (guix derivations)
#:use-module (guix packages)
#:autoload (guix build-system gnu) (standard-inputs)
#:use-module (ice-9 match)
@@ -46,9 +47,15 @@
(recursive? git-reference-recursive? ; whether to recurse into sub-modules
(default #f)))
+(define (git-package)
+ "Return the default Git package."
+ (let ((distro (resolve-interface '(gnu packages version-control))))
+ (module-ref distro 'git)))
+
(define* (git-fetch store ref hash-algo hash
#:optional name
- #:key (system (%current-system)) guile git)
+ #:key (system (%current-system)) guile
+ (git (git-package)))
"Return a fixed-output derivation in STORE that fetches REF, a
<git-reference> object. The output is expected to have recursive hash HASH of
type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if
@@ -62,15 +69,6 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if
(guile (module-ref distro 'guile-final)))
(package-derivation store guile system)))))
- (define git-for-build
- (match git
- ((? package?)
- (package-derivation store git system))
- (#f ; the default
- (let* ((distro (resolve-interface '(gnu packages version-control)))
- (git (module-ref distro 'git)))
- (package-derivation store git system)))))
-
(define inputs
;; When doing 'git clone --recursive', we need sed, grep, etc. to be
;; available so that 'git submodule' works.
@@ -78,36 +76,37 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if
(standard-inputs (%current-system))
'()))
- (let* ((command (string-append (derivation->output-path git-for-build)
- "/bin/git"))
- (builder `(begin
- (use-modules (guix build git)
- (guix build utils)
- (ice-9 match))
+ (define build
+ #~(begin
+ (use-modules (guix build git)
+ (guix build utils)
+ (ice-9 match))
+
+ ;; The 'git submodule' commands expects Coreutils, sed,
+ ;; grep, etc. to be in $PATH.
+ (set-path-environment-variable "PATH" '("bin")
+ (match '#$inputs
+ (((names dirs) ...)
+ dirs)))
- ;; The 'git submodule' commands expects Coreutils, sed,
- ;; grep, etc. to be in $PATH.
- (set-path-environment-variable "PATH" '("bin")
- (match %build-inputs
- (((names . dirs) ...)
- dirs)))
+ (git-fetch '#$(git-reference-url ref)
+ '#$(git-reference-commit ref)
+ #$output
+ #:recursive? '#$(git-reference-recursive? ref)
+ #:git-command (string-append #$git "/bin/git"))))
- (git-fetch ',(git-reference-url ref)
- ',(git-reference-commit ref)
- %output
- #:recursive? ',(git-reference-recursive? ref)
- #:git-command ',command))))
- (build-expression->derivation store (or name "git-checkout") builder
- #:system system
- #:local-build? #t
- #:inputs `(("git" ,git-for-build)
- ,@inputs)
- #:hash-algo hash-algo
- #:hash hash
- #:recursive? #t
- #:modules '((guix build git)
- (guix build utils))
- #:guile-for-build guile-for-build
- #:local-build? #t)))
+ (run-with-store store
+ (gexp->derivation (or name "git-checkout") build
+ #:system system
+ #:local-build? #t
+ #:hash-algo hash-algo
+ #:hash hash
+ #:recursive? #t
+ #:modules '((guix build git)
+ (guix build utils))
+ #:guile-for-build guile-for-build
+ #:local-build? #t)
+ #:guile-for-build guile-for-build
+ #:system system))
;;; git-download.scm ends here
diff --git a/guix/profiles.scm b/guix/profiles.scm
index e921566e5a..bf86624e43 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,14 +19,17 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix profiles)
+ #:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix gexp)
+ #:use-module (guix monads)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 ftw)
+ #:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
@@ -51,6 +55,13 @@
manifest-installed?
manifest-matching-entries
+ manifest-transaction
+ manifest-transaction?
+ manifest-transaction-install
+ manifest-transaction-remove
+ manifest-perform-transaction
+ manifest-show-transaction
+
profile-manifest
package->manifest-entry
profile-derivation
@@ -244,39 +255,191 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
;;;
-;;; Profiles.
+;;; Manifest transactions.
;;;
-(define (profile-derivation manifest)
- "Return a derivation that builds a profile (aka. 'user environment') with
-the given MANIFEST."
- (define inputs
- (append-map (match-lambda
- (($ <manifest-entry> name version
- output (? package? package) deps)
- `((,package ,output) ,@deps))
- (($ <manifest-entry> name version output path deps)
- ;; Assume PATH and DEPS are already valid.
- `(,path ,@deps)))
- (manifest-entries manifest)))
-
- (define builder
- #~(begin
- (use-modules (ice-9 pretty-print)
- (guix build union))
-
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
+(define-record-type* <manifest-transaction> manifest-transaction
+ make-manifest-transaction
+ manifest-transaction?
+ (install manifest-transaction-install ; list of <manifest-entry>
+ (default '()))
+ (remove manifest-transaction-remove ; list of <manifest-pattern>
+ (default '())))
+
+(define (manifest-perform-transaction manifest transaction)
+ "Perform TRANSACTION on MANIFEST and return new manifest."
+ (let ((install (manifest-transaction-install transaction))
+ (remove (manifest-transaction-remove transaction)))
+ (manifest-add (manifest-remove manifest remove)
+ install)))
+
+(define* (manifest-show-transaction store manifest transaction
+ #:key dry-run?)
+ "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
+ (define (package-strings name version output item)
+ (map (lambda (name version output item)
+ (format #f " ~a-~a\t~a\t~a" name version output
+ (if (package? item)
+ (package-output store item output)
+ item)))
+ name version output item))
+
+ (let* ((remove (manifest-matching-entries
+ manifest (manifest-transaction-remove transaction)))
+ (install/upgrade (manifest-transaction-install transaction))
+ (install '())
+ (upgrade (append-map
+ (lambda (entry)
+ (let ((matching
+ (manifest-matching-entries
+ manifest
+ (list (manifest-pattern
+ (name (manifest-entry-name entry))
+ (output (manifest-entry-output entry)))))))
+ (when (null? matching)
+ (set! install (cons entry install)))
+ matching))
+ install/upgrade)))
+ (match remove
+ ((($ <manifest-entry> name version output item _) ..1)
+ (let ((len (length name))
+ (remove (package-strings name version output item)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be removed:~%~{~a~%~}~%"
+ "The following packages would be removed:~%~{~a~%~}~%"
+ len)
+ remove)
+ (format (current-error-port)
+ (N_ "The following package will be removed:~%~{~a~%~}~%"
+ "The following packages will be removed:~%~{~a~%~}~%"
+ len)
+ remove))))
+ (_ #f))
+ (match upgrade
+ ((($ <manifest-entry> name version output item _) ..1)
+ (let ((len (length name))
+ (upgrade (package-strings name version output item)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be upgraded:~%~{~a~%~}~%"
+ "The following packages would be upgraded:~%~{~a~%~}~%"
+ len)
+ upgrade)
+ (format (current-error-port)
+ (N_ "The following package will be upgraded:~%~{~a~%~}~%"
+ "The following packages will be upgraded:~%~{~a~%~}~%"
+ len)
+ upgrade))))
+ (_ #f))
+ (match install
+ ((($ <manifest-entry> name version output item _) ..1)
+ (let ((len (length name))
+ (install (package-strings name version output item)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be installed:~%~{~a~%~}~%"
+ "The following packages would be installed:~%~{~a~%~}~%"
+ len)
+ install)
+ (format (current-error-port)
+ (N_ "The following package will be installed:~%~{~a~%~}~%"
+ "The following packages will be installed:~%~{~a~%~}~%"
+ len)
+ install))))
+ (_ #f))))
- (union-build #$output '#$inputs
- #:log-port (%make-void-port "w"))
- (call-with-output-file (string-append #$output "/manifest")
- (lambda (p)
- (pretty-print '#$(manifest->gexp manifest) p)))))
+
+;;;
+;;; Profiles.
+;;;
- (gexp->derivation "profile" builder
- #:modules '((guix build union))
- #:local-build? #t))
+(define (manifest-inputs manifest)
+ "Return the list of inputs for MANIFEST. Each input has one of the
+following forms:
+
+ (PACKAGE OUTPUT-NAME)
+
+or
+
+ STORE-PATH
+"
+ (append-map (match-lambda
+ (($ <manifest-entry> name version
+ output (? package? package) deps)
+ `((,package ,output) ,@deps))
+ (($ <manifest-entry> name version output path deps)
+ ;; Assume PATH and DEPS are already valid.
+ `(,path ,@deps)))
+ (manifest-entries manifest)))
+
+(define (info-dir-file manifest)
+ "Return a derivation that builds the 'dir' file for all the entries of
+MANIFEST."
+ (define texinfo
+ ;; Lazy reference.
+ (module-ref (resolve-interface '(gnu packages texinfo))
+ 'texinfo))
+ (define build
+ #~(begin
+ (use-modules (guix build utils)
+ (srfi srfi-1) (srfi srfi-26)
+ (ice-9 ftw))
+
+ (define (info-file? file)
+ (or (string-suffix? ".info" file)
+ (string-suffix? ".info.gz" file)))
+
+ (define (info-files top)
+ (let ((infodir (string-append top "/share/info")))
+ (map (cut string-append infodir "/" <>)
+ (scandir infodir info-file?))))
+
+ (define (install-info info)
+ (zero?
+ (system* (string-append #+texinfo "/bin/install-info")
+ info (string-append #$output "/share/info/dir"))))
+
+ (mkdir-p (string-append #$output "/share/info"))
+ (every install-info
+ (append-map info-files
+ '#$(manifest-inputs manifest)))))
+
+ ;; Don't depend on Texinfo when there's nothing to do.
+ (if (null? (manifest-entries manifest))
+ (gexp->derivation "info-dir" #~(mkdir #$output))
+ (gexp->derivation "info-dir" build
+ #:modules '((guix build utils)))))
+
+(define* (profile-derivation manifest #:key (info-dir? #t))
+ "Return a derivation that builds a profile (aka. 'user environment') with
+the given MANIFEST. The profile includes a top-level Info 'dir' file, unless
+INFO-DIR? is #f."
+ (mlet %store-monad ((info-dir (if info-dir?
+ (info-dir-file manifest)
+ (return #f))))
+ (define inputs
+ (if info-dir
+ (cons info-dir (manifest-inputs manifest))
+ (manifest-inputs manifest)))
+
+ (define builder
+ #~(begin
+ (use-modules (ice-9 pretty-print)
+ (guix build union))
+
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (union-build #$output '#$inputs
+ #:log-port (%make-void-port "w"))
+ (call-with-output-file (string-append #$output "/manifest")
+ (lambda (p)
+ (pretty-print '#$(manifest->gexp manifest) p)))))
+
+ (gexp->derivation "profile" builder
+ #:modules '((guix build union))
+ #:local-build? #t)))
(define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number."
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 3bfef4fc9a..fb285c5e67 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -29,7 +29,6 @@
#:use-module (guix config)
#:use-module (guix scripts build)
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
- #:use-module ((guix ftp-client) #:select (ftp-open))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@@ -42,7 +41,6 @@
#:use-module (gnu packages)
#:use-module ((gnu packages base) #:select (guile-final))
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
- #:use-module (guix gnu-maintenance)
#:export (specification->package+output
guix-package))
@@ -184,49 +182,6 @@ DURATION-RELATION with the current time."
filter-by-duration)
(else #f)))
-(define (show-what-to-remove/install remove install dry-run?)
- "Given the manifest entries listed in REMOVE and INSTALL, display the
-packages that will/would be installed and removed."
- ;; TODO: Report upgrades more clearly.
- (match remove
- ((($ <manifest-entry> name version output path _) ..1)
- (let ((len (length name))
- (remove (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
- name version output path)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be removed:~%~{~a~%~}~%"
- "The following packages would be removed:~%~{~a~%~}~%"
- len)
- remove)
- (format (current-error-port)
- (N_ "The following package will be removed:~%~{~a~%~}~%"
- "The following packages will be removed:~%~{~a~%~}~%"
- len)
- remove))))
- (_ #f))
- (match install
- ((($ <manifest-entry> name version output item _) ..1)
- (let ((len (length name))
- (install (map (lambda (name version output item)
- (format #f " ~a-~a\t~a\t~a" name version output
- (if (package? item)
- (package-output (%store) item output)
- item)))
- name version output item)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be installed:~%~{~a~%~}~%"
- "The following packages would be installed:~%~{~a~%~}~%"
- len)
- install)
- (format (current-error-port)
- (N_ "The following package will be installed:~%~{~a~%~}~%"
- "The following packages will be installed:~%~{~a~%~}~%"
- len)
- install))))
- (_ #f)))
-
;;;
;;; Package specifications.
@@ -258,48 +213,6 @@ RX."
(package-name p2))))
same-location?))
-(define %sigint-prompt
- ;; The prompt to jump to upon SIGINT.
- (make-prompt-tag "interruptible"))
-
-(define (call-with-sigint-handler thunk handler)
- "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal
-number in the context of the continuation of the call to this function, and
-return its return value."
- (call-with-prompt %sigint-prompt
- (lambda ()
- (sigaction SIGINT
- (lambda (signum)
- (sigaction SIGINT SIG_DFL)
- (abort-to-prompt %sigint-prompt signum)))
- (dynamic-wind
- (const #t)
- thunk
- (cut sigaction SIGINT SIG_DFL)))
- (lambda (k signum)
- (handler signum))))
-
-(define-syntax-rule (waiting exp fmt rest ...)
- "Display the given message while EXP is being evaluated."
- (let* ((message (format #f fmt rest ...))
- (blank (make-string (string-length message) #\space)))
- (display message (current-error-port))
- (force-output (current-error-port))
- (call-with-sigint-handler
- (lambda ()
- (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-syntax-rule (leave-on-EPIPE exp ...)
"Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
with successful exit code. This is useful when writing to the standard output
@@ -363,41 +276,6 @@ an output path different than CURRENT-PATH."
(not (string=? current-path candidate-path))))))
(#f #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."
- ;; TODO: Automatically inject the upstream version when desired.
-
- (catch #t
- (lambda ()
- (when (false-if-exception (gnu-package? package))
- (let ((name (package-name package))
- (full-name (package-full-name package)))
- (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)
- (format (current-error-port)
- (_ "~a: note: using ~a \
-but ~a is available upstream~%")
- (location->string (package-location package))
- full-name latest-version)))
- (_ #t)))))
- (lambda (key . args)
- ;; Silently ignore networking errors rather than preventing
- ;; installation.
- (case key
- ((getaddrinfo-error ftp-error) #f)
- (else (apply throw key args))))))
-
;;;
;;; Search paths.
@@ -863,21 +741,26 @@ more information.~%"))
(_ #f))
opts))
(else
- (let* ((manifest (profile-manifest profile))
- (install (options->installable opts manifest))
- (remove (options->removable opts manifest))
- (new (manifest-add (manifest-remove manifest remove)
- install)))
+ (let* ((manifest (profile-manifest profile))
+ (install (options->installable opts manifest))
+ (remove (options->removable opts manifest))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (transaction (manifest-transaction (install install)
+ (remove remove)))
+ (new (manifest-perform-transaction
+ manifest transaction)))
(when (equal? profile %current-profile)
(ensure-default-profile))
(unless (and (null? install) (null? remove))
(let* ((prof-drv (run-with-store (%store)
- (profile-derivation new)))
- (prof (derivation->output-path prof-drv))
- (remove (manifest-matching-entries manifest remove)))
- (show-what-to-remove/install remove install dry-run?)
+ (profile-derivation
+ new
+ #:info-dir? (not bootstrap?))))
+ (prof (derivation->output-path prof-drv)))
+ (manifest-show-transaction (%store) manifest transaction
+ #:dry-run? dry-run?)
(show-what-to-build (%store) (list prof-drv)
#:use-substitutes?
(assoc-ref opts 'substitutes?)
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index 9b2b24d92d..cb4d9dcc11 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -19,7 +19,8 @@
(define-module (guix svn-download)
#:use-module (guix records)
- #:use-module (guix derivations)
+ #:use-module (guix gexp)
+ #:use-module (guix monads)
#:use-module (guix packages)
#:use-module (ice-9 match)
#:export (svn-reference
@@ -42,9 +43,15 @@
(url svn-reference-url) ; string
(revision svn-reference-revision)) ; number
+(define (subversion-package)
+ "Return the default Subversion package."
+ (let ((distro (resolve-interface '(gnu packages version-control))))
+ (module-ref distro 'subversion)))
+
(define* (svn-fetch store ref hash-algo hash
#:optional name
- #:key (system (%current-system)) guile svn)
+ #:key (system (%current-system)) guile
+ (svn (subversion-package)))
"Return a fixed-output derivation in STORE that fetches REF, a
<svn-reference> object. The output is expected to have recursive hash HASH of
type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if
@@ -58,33 +65,26 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if
(guile (module-ref distro 'guile-final)))
(package-derivation store guile system)))))
- (define svn-for-build
- (match svn
- ((? package?)
- (package-derivation store svn system))
- (#f ; the default
- (let* ((distro (resolve-interface '(gnu packages version-control)))
- (svn (module-ref distro 'subversion)))
- (package-derivation store svn system)))))
+ (define build
+ #~(begin
+ (use-modules (guix build svn))
+ (svn-fetch '#$(svn-reference-url ref)
+ '#$(svn-reference-revision ref)
+ #$output
+ #:svn-command (string-append #$svn "/bin/svn"))))
- (let* ((command (string-append (derivation->output-path svn-for-build)
- "/bin/svn"))
- (builder `(begin
- (use-modules (guix build svn))
- (svn-fetch ',(svn-reference-url ref)
- ',(svn-reference-revision ref)
- %output
- #:svn-command ',command))))
- (build-expression->derivation store (or name "svn-checkout") builder
- #:system system
- #:local-build? #t
- #:inputs `(("svn" ,svn-for-build))
- #:hash-algo hash-algo
- #:hash hash
- #:recursive? #t
- #:modules '((guix build svn)
- (guix build utils))
- #:guile-for-build guile-for-build
- #:local-build? #t)))
+ (run-with-store store
+ (gexp->derivation (or name "svn-checkout") build
+ #:system system
+ #:local-build? #t
+ #:hash-algo hash-algo
+ #:hash hash
+ #:recursive? #t
+ #:modules '((guix build svn)
+ (guix build utils))
+ #:guile-for-build guile-for-build
+ #:local-build? #t)
+ #:guile-for-build guile-for-build
+ #:system system))
;;; svn-download.scm ends here
diff --git a/guix/tests.scm b/guix/tests.scm
new file mode 100644
index 0000000000..4f7b0c8171
--- /dev/null
+++ b/guix/tests.scm
@@ -0,0 +1,70 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.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 tests)
+ #:use-module (guix store)
+ #:use-module (guix derivations)
+ #:use-module (guix packages)
+ #:use-module (gnu packages bootstrap)
+ #:use-module (srfi srfi-34)
+ #:use-module (rnrs bytevectors)
+ #:export (open-connection-for-tests
+ random-text
+ random-bytevector))
+
+;;; Commentary:
+;;;
+;;; This module provide shared infrastructure for the test suite. For
+;;; internal use only.
+;;;
+;;; Code:
+
+(define (open-connection-for-tests)
+ "Open a connection to the build daemon for tests purposes and return it."
+ (guard (c ((nix-error? c)
+ (format (current-error-port)
+ "warning: build daemon error: ~s~%" c)
+ #f))
+ (let ((store (open-connection)))
+ ;; Make sure we build everything by ourselves.
+ (set-build-options store #:use-substitutes? #f)
+
+ ;; Use the bootstrap Guile when running tests, so we don't end up
+ ;; building everything in the temporary test store.
+ (%guile-for-build (package-derivation store %bootstrap-guile))
+
+ store)))
+
+(define %seed
+ (seed->random-state (logxor (getpid) (car (gettimeofday)))))
+
+(define (random-text)
+ "Return the hexadecimal representation of a random number."
+ (number->string (random (expt 2 256) %seed) 16))
+
+(define (random-bytevector n)
+ "Return a random bytevector of N bytes."
+ (let ((bv (make-bytevector n)))
+ (let loop ((i 0))
+ (if (< i n)
+ (begin
+ (bytevector-u8-set! bv i (random 256 %seed))
+ (loop (1+ i)))
+ bv))))
+
+;;; tests.scm ends here
diff --git a/tests/builders.scm b/tests/builders.scm
index 0ed5d74a22..54cdeb6d7b 100644
--- a/tests/builders.scm
+++ b/tests/builders.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -25,6 +25,7 @@
#:use-module (guix utils)
#:use-module (guix base32)
#:use-module (guix derivations)
+ #:use-module (guix tests)
#:use-module ((guix packages)
#:select (package-derivation package-native-search-paths))
#:use-module (gnu packages bootstrap)
@@ -35,11 +36,7 @@
;; Test the higher-level builders.
(define %store
- (false-if-exception (open-connection)))
-
-(when %store
- ;; Make sure we build everything by ourselves.
- (set-build-options %store #:use-substitutes? #f))
+ (open-connection-for-tests))
(define %bootstrap-inputs
;; Use the bootstrap inputs so it doesn't take ages to run these tests.
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 87609108d6..19bcebcb21 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -16,13 +16,13 @@
;;; 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 (test-derivations)
#:use-module (guix derivations)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix hash)
#:use-module (guix base32)
+ #:use-module (guix tests)
#:use-module ((guix packages) #:select (package-derivation base32))
#:use-module ((guix build utils) #:select (executable-file?))
#:use-module ((gnu packages) #:select (search-bootstrap-binary))
@@ -42,15 +42,7 @@
#:use-module (ice-9 match))
(define %store
- (false-if-exception (open-connection)))
-
-(when %store
- ;; Make sure we build everything by ourselves.
- (set-build-options %store #:use-substitutes? #f)
-
- ;; By default, use %BOOTSTRAP-GUILE for the current system.
- (let ((drv (package-derivation %store %bootstrap-guile)))
- (%guile-for-build drv)))
+ (open-connection-for-tests))
(define (bootstrap-binary name)
(let ((bin (search-bootstrap-binary name (%current-system))))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 694bd409bc..bf52401c66 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -22,6 +22,7 @@
#:use-module (guix gexp)
#:use-module (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix tests)
#:use-module (gnu packages)
#:use-module (gnu packages base)
#:use-module (gnu packages bootstrap)
@@ -35,28 +36,22 @@
;; Test the (guix gexp) module.
(define %store
- (open-connection))
+ (open-connection-for-tests))
;; For white-box testing.
(define gexp-inputs (@@ (guix gexp) gexp-inputs))
(define gexp-native-inputs (@@ (guix gexp) gexp-native-inputs))
(define gexp->sexp (@@ (guix gexp) gexp->sexp))
-(define guile-for-build
- (package-derivation %store %bootstrap-guile))
-
-;; Make it the default.
-(%guile-for-build guile-for-build)
-
(define* (gexp->sexp* exp #:optional target)
(run-with-store %store (gexp->sexp exp
#:target target)
- #:guile-for-build guile-for-build))
+ #:guile-for-build (%guile-for-build)))
(define-syntax-rule (test-assertm name exp)
(test-assert name
(run-with-store %store exp
- #:guile-for-build guile-for-build)))
+ #:guile-for-build (%guile-for-build))))
(test-begin "gexp")
@@ -330,7 +325,7 @@
(derivation-file-name xdrv)))))
(define shebang
- (string-append "#!" (derivation->output-path guile-for-build)
+ (string-append "#!" (derivation->output-path (%guile-for-build))
"/bin/guile --no-auto-compile"))
;; If we're going to hit the silly shebang limit (128 chars on Linux-based
diff --git a/tests/monads.scm b/tests/monads.scm
index b814b0f7c5..b31cabdb54 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-monads)
+ #:use-module (guix tests)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations)
@@ -34,10 +35,7 @@
;; Test the (guix store) module.
(define %store
- (open-connection))
-
-;; Make sure we build everything by ourselves.
-(set-build-options %store #:use-substitutes? #f)
+ (open-connection-for-tests))
(define %monads
(list %identity-monad %store-monad))
diff --git a/tests/nar.scm b/tests/nar.scm
index 16a7845342..3188599bf1 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-nar)
+ #:use-module (guix tests)
#:use-module (guix nar)
#:use-module (guix store)
#:use-module ((guix hash)
@@ -134,19 +135,10 @@
input
lstat))
-(define (make-random-bytevector n)
- (let ((bv (make-bytevector n)))
- (let loop ((i 0))
- (if (< i n)
- (begin
- (bytevector-u8-set! bv i (random 256))
- (loop (1+ i)))
- bv))))
-
(define (populate-file file size)
(call-with-output-file file
(lambda (p)
- (put-bytevector p (make-random-bytevector size)))))
+ (put-bytevector p (random-bytevector size)))))
(define (rm-rf dir)
(file-system-fold (const #t) ; enter?
@@ -166,13 +158,6 @@
(string-append (dirname (search-path %load-path "pre-inst-env"))
"/test-nar-" (number->string (getpid))))
-;; XXX: Factorize.
-(define %seed
- (seed->random-state (logxor (getpid) (car (gettimeofday)))))
-
-(define (random-text)
- (number->string (random (expt 2 256) %seed) 16))
-
(define-syntax-rule (let/ec k exp...)
;; This one appeared in Guile 2.0.9, so provide a copy here.
(let ((tag (make-prompt-tag)))
diff --git a/tests/packages.scm b/tests/packages.scm
index 6ac215be4c..2a67f108ad 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -16,8 +16,8 @@
;;; 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 (test-packages)
+ #:use-module (guix tests)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix hash)
@@ -39,11 +39,8 @@
;; Test the high-level packaging layer.
(define %store
- (false-if-exception (open-connection)))
+ (open-connection-for-tests))
-(when %store
- ;; Make sure we build everything by ourselves.
- (set-build-options %store #:use-substitutes? #f))
(test-begin "packages")
diff --git a/tests/profiles.scm b/tests/profiles.scm
index b2919d7315..047c5ba49b 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-profiles)
+ #:use-module (guix tests)
#:use-module (guix profiles)
#:use-module (guix store)
#:use-module (guix monads)
@@ -26,17 +28,10 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-64))
-;; Test the (guix profile) module.
+;; Test the (guix profiles) module.
(define %store
- (open-connection))
-
-(define guile-for-build
- (package-derivation %store %bootstrap-guile))
-
-;; Make it the default.
-(%guile-for-build guile-for-build)
-
+ (open-connection-for-tests))
;; Example manifest entries.
@@ -122,12 +117,32 @@
(_ #f))
(equal? m3 m4))))
+(test-assert "manifest-perform-transaction"
+ (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
+ (t1 (manifest-transaction
+ (install (list guile-1.8.8))
+ (remove (list (manifest-pattern (name "guile")
+ (output "debug"))))))
+ (t2 (manifest-transaction
+ (remove (list (manifest-pattern (name "guile")
+ (version "2.0.9")
+ (output #f))))))
+ (m1 (manifest-perform-transaction m0 t1))
+ (m2 (manifest-perform-transaction m1 t2))
+ (m3 (manifest-perform-transaction m0 t2)))
+ (and (match (manifest-entries m1)
+ ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
+ (_ #f))
+ (equal? m1 m2)
+ (null? (manifest-entries m3)))))
+
(test-assert "profile-derivation"
(run-with-store %store
(mlet* %store-monad
((entry -> (package->manifest-entry %bootstrap-guile))
(guile (package->derivation %bootstrap-guile))
- (drv (profile-derivation (manifest (list entry))))
+ (drv (profile-derivation (manifest (list entry))
+ #:info-dir? #f))
(profile -> (derivation->output-path drv))
(bindir -> (string-append profile "/bin"))
(_ (built-derivations (list drv))))
diff --git a/tests/store.scm b/tests/store.scm
index b0f609f818..ba15524be4 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -16,8 +16,8 @@
;;; 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 (test-store)
+ #:use-module (guix tests)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix hash)
@@ -40,17 +40,7 @@
;; Test the (guix store) module.
(define %store
- (false-if-exception (open-connection)))
-
-(when %store
- ;; Make sure we build everything by ourselves.
- (set-build-options %store #:use-substitutes? #f))
-
-(define %seed
- (seed->random-state (logxor (getpid) (car (gettimeofday)))))
-
-(define (random-text)
- (number->string (random (expt 2 256) %seed) 16))
+ (open-connection-for-tests))
(test-begin "store")
diff --git a/tests/union.scm b/tests/union.scm
index 74c51cbed9..7e55670b86 100644
--- a/tests/union.scm
+++ b/tests/union.scm
@@ -16,8 +16,8 @@
;;; 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 (test-union)
+ #:use-module (guix tests)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix derivations)
@@ -34,12 +34,7 @@
;; Exercise the (guix build union) module.
(define %store
- (false-if-exception (open-connection)))
-
-(when %store
- ;; By default, use %BOOTSTRAP-GUILE for the current system.
- (let ((drv (package-derivation %store %bootstrap-guile)))
- (%guile-for-build drv)))
+ (open-connection-for-tests))
(test-begin "union")