nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into core-updates

master
Mark H Weaver 2014-08-23 20:43:51 -04:00
parent fa5731baab f0dafadcfc
commit ce3e35ed6a
21 changed files with 482 additions and 319 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Makefile.am
View File

@ -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

1
THANKS
View File

@ -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>

88
gnu/packages.scm
View File

@ -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))))))

4
gnu/packages/bdw-gc.scm
View File

@ -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

4
gnu/packages/gnupg.scm
View File

@ -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

4
gnu/packages/video.scm
View File

@ -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)

2
guix/download.scm
View File

@ -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)))

79
guix/git-download.scm
View File

@ -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 %build-inputs
(((names . dirs) ...)
dirs)))
;; The 'git submodule' commands expects Coreutils, sed,
;; grep, etc. to be in $PATH.
(set-path-environment-variable "PATH" '("bin")
(match '#$inputs
(((names dirs) ...)
dirs)))
(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)))
(git-fetch '#$(git-reference-url ref)
'#$(git-reference-commit ref)
#$output
#:recursive? '#$(git-reference-recursive? ref)
#:git-command (string-append #$git "/bin/git"))))
(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

213
guix/profiles.scm
View File

@ -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
@ -242,41 +253,193 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
(filter matches? (manifest-entries manifest)))
;;;
;;; Manifest transactions.
;;;
(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))))
;;;
;;; Profiles.
;;;
(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 (manifest-inputs manifest)
"Return the list of inputs for MANIFEST. Each input has one of the
following forms:
(define builder
(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 (ice-9 pretty-print)
(guix build union))
(use-modules (guix build utils)
(srfi srfi-1) (srfi srfi-26)
(ice-9 ftw))
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
(define (info-file? file)
(or (string-suffix? ".info" file)
(string-suffix? ".info.gz" file)))
(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)))))
(define (info-files top)
(let ((infodir (string-append top "/share/info")))
(map (cut string-append infodir "/" <>)
(scandir infodir info-file?))))
(gexp->derivation "profile" builder
#:modules '((guix build union))
#:local-build? #t))
(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."

145
guix/scripts/package.scm
View File

@ -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?)

58
guix/svn-download.scm
View File

@ -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

70
guix/tests.scm Normal file
View File

@ -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

9
tests/builders.scm
View File

@ -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.

12
tests/derivations.scm
View File

@ -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))))

15
tests/gexp.scm
View File

@ -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

6
tests/monads.scm
View File

@ -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))

19
tests/nar.scm
View File

@ -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)))

9
tests/packages.scm
View File

@ -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")

35
tests/profiles.scm
View File

@ -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))))

14
tests/store.scm
View File

@ -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")

9
tests/union.scm
View File

@ -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")