diff options
| -rw-r--r-- | Makefile.am | 5 | ||||
| -rw-r--r-- | THANKS | 1 | ||||
| -rw-r--r-- | gnu/packages.scm | 88 | ||||
| -rw-r--r-- | gnu/packages/bdw-gc.scm | 4 | ||||
| -rw-r--r-- | gnu/packages/gnupg.scm | 4 | ||||
| -rw-r--r-- | gnu/packages/video.scm | 4 | ||||
| -rw-r--r-- | guix/download.scm | 2 | ||||
| -rw-r--r-- | guix/git-download.scm | 79 | ||||
| -rw-r--r-- | guix/profiles.scm | 221 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 145 | ||||
| -rw-r--r-- | guix/svn-download.scm | 58 | ||||
| -rw-r--r-- | guix/tests.scm | 70 | ||||
| -rw-r--r-- | tests/builders.scm | 9 | ||||
| -rw-r--r-- | tests/derivations.scm | 12 | ||||
| -rw-r--r-- | tests/gexp.scm | 15 | ||||
| -rw-r--r-- | tests/monads.scm | 6 | ||||
| -rw-r--r-- | tests/nar.scm | 19 | ||||
| -rw-r--r-- | tests/packages.scm | 9 | ||||
| -rw-r--r-- | tests/profiles.scm | 35 | ||||
| -rw-r--r-- | tests/store.scm | 14 | ||||
| -rw-r--r-- | tests/union.scm | 9 |
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 @@ -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") |