ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into core-updates

Browse source 
Conflicts:
	guix/packages.scm
This commit is contained in:
Ludovic Courtès 2013-11-08 21:58:09 +01:00
commit 7db9608d52
17 changed files with 1023 additions and 363 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
.dir-locals.el
View file

@ -14,6 +14,9 @@
(eval . (put 'substitute* 'scheme-indent-function 1))
(eval . (put 'with-directory-excursion 'scheme-indent-function 1))
(eval . (put 'package 'scheme-indent-function 0))
(eval . (put 'origin 'scheme-indent-function 0))
(eval . (put 'manifest-entry 'scheme-indent-function 0))
(eval . (put 'manifest-pattern 'scheme-indent-function 0))
(eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1))
(eval . (put 'with-error-handling 'scheme-indent-function 0))
(eval . (put 'with-mutex 'scheme-indent-function 1))

4
Makefile.am
View file

@ -41,6 +41,7 @@ MODULES = \
guix/hash.scm \
guix/utils.scm \
guix/monads.scm \
guix/profiles.scm \
guix/serialization.scm \
guix/nar.scm \
guix/derivations.scm \
@ -114,7 +115,8 @@ SCM_TESTS = \
tests/store.scm \
tests/monads.scm \
tests/nar.scm \
tests/union.scm
tests/union.scm \
tests/profiles.scm
SH_TESTS = \
tests/guix-build.sh \

51
doc/guix.texi
View file

@ -288,9 +288,18 @@ Take users from @var{group} to run build processes (@pxref{Setting Up
the Daemon, build users}).
@item --no-substitutes
@cindex substitutes
Do not use substitutes for build products. That is, always build things
locally instead of allowing downloads of pre-built binaries.
By default substitutes are used, unless the client---such as the
@command{guix package} command---is explicitly invoked with
@code{--no-substitutes}.
When the daemon runs with @code{--no-substitutes}, clients can still
explicitly enable substitution @i{via} the @code{set-build-options}
remote procedure call (@pxref{The Store}).
@item --cache-failures
Cache build failures. By default, only successful builds are cached.
@ -446,10 +455,18 @@ scripts, etc. This direct correspondence allows users to make sure a
given package installation matches the current state of their
distribution, and helps maximize @dfn{reproducibility}.
@cindex substitute
This foundation allows Guix to support @dfn{transparent binary/source
deployment}. When a pre-built binary for a @file{/nix/store} path is
available from an external source, Guix just downloads it; otherwise, it
builds the package from source, locally.
available from an external source---a @dfn{substitute}, Guix just
downloads it@footnote{@c XXX: Remove me when outdated.
As of version @value{VERSION}, substitutes are downloaded from
@url{http://hydra.gnu.org/} but are @emph{not} authenticated---i.e.,
Guix cannot tell whether binaries it downloaded have been tampered with,
nor whether they come from the genuine @code{gnu.org} build farm. This
will be fixed in future versions. In the meantime, concerned users can
opt for @code{--no-substitutes} (@pxref{Invoking guix-daemon}).};
otherwise, it builds the package from source, locally.
@node Invoking guix package
@section Invoking @command{guix package}
@ -540,6 +557,11 @@ multiple-output package.
@itemx -r @var{package}
Remove @var{package}.
As for @code{--install}, @var{package} may specify a version number
and/or output name in addition to the package name. For instance,
@code{-r glibc:debug} would remove the @code{debug} output of
@code{glibc}.
@item --upgrade[=@var{regexp}]
@itemx -u [@var{regexp}]
Upgrade all the installed packages. When @var{regexp} is specified, upgrade
@ -593,7 +615,10 @@ When substituting a pre-built binary fails, fall back to building
packages locally.
@item --no-substitutes
@itemx --max-silent-time=@var{seconds}
Do not use substitutes for build products. That is, always build things
locally instead of allowing downloads of pre-built binaries.
@item --max-silent-time=@var{seconds}
Same as for @command{guix build} (@pxref{Invoking guix build}).
@item --verbose
@ -960,6 +985,11 @@ base32 representation of the hash. You can obtain this information with
@code{guix download} (@pxref{Invoking guix download}) and @code{guix
hash} (@pxref{Invoking guix hash}).
@cindex patches
When needed, the @code{origin} form can also have a @code{patches} field
listing patches to be applied, and a @code{snippet} field giving a
Scheme expression to modify the source code.
@item
@cindex GNU Build System
The @code{build-system} field is set to @var{gnu-build-system}. The
@ -1454,6 +1484,10 @@ themselves.
For instance, @code{guix build -S gcc} returns something like
@file{/nix/store/@dots{}-gcc-4.7.2.tar.bz2}, which is GCC's source tarball.
The returned source tarball is the result of applying any patches and
code snippets specified in the package's @code{origin} (@pxref{Defining
Packages}).
@item --system=@var{system}
@itemx -s @var{system}
Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of
@ -1490,7 +1524,8 @@ When substituting a pre-built binary fails, fall back to building
packages locally.
@item --no-substitutes
Build instead of resorting to pre-built substitutes.
Do not use substitutes for build products. That is, always build things
locally instead of allowing downloads of pre-built binaries.
@item --max-silent-time=@var{seconds}
When the build or substitution process remains silent for more than
@ -1852,6 +1887,14 @@ software distribution guidelines}. Among other things, these guidelines
reject non-free firmware, recommendations of non-free software, and
discuss ways to deal with trademarks and patents.
Some packages contain a small and optional subset that violates the
above guidelines, for instance because this subset is itself non-free
code. When that happens, the offending items are removed with
appropriate patches or code snippets in the package definition's
@code{origin} form (@pxref{Defining Packages}). That way, @code{guix
build --source} returns the ``freed'' source rather than the unmodified
upstream source.
@node Package Naming
@subsection Package Naming

1
gnu-system.am
View file

@ -179,6 +179,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/unrtf.scm \
gnu/packages/valgrind.scm \
gnu/packages/version-control.scm \
gnu/packages/video.scm \
gnu/packages/vim.scm \
gnu/packages/vpn.scm \
gnu/packages/w3m.scm \

4
gnu/packages/cmake.scm
View file

@ -27,7 +27,7 @@ (define-module (gnu packages cmake)
(define-public cmake
(package
(name "cmake")
(version "2.8.10.2")
(version "2.8.12")
(source (origin
(method url-fetch)
(uri (string-append
@ -36,7 +36,7 @@ (define-public cmake
(string-index version #\. (+ 1 (string-index version #\.))))
"/cmake-" version ".tar.gz"))
(sha256
(base32 "1c8fj6i2x9sb39wc9av2ighj415mw33cxfrlfpafcvm0knrlylnf"))
(base32 "11q21vyrr6c6smyjy81k2k07zmn96ggjia9im9cxwvj0n88bm1fq"))
(patches (list (search-patch "cmake-fix-tests.patch")))))
(build-system gnu-build-system)
(arguments

30
gnu/packages/gcc.scm
View file

@ -27,6 +27,7 @@ (define-module (gnu packages gcc)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix utils)
#:use-module (ice-9 regex))
(define %gcc-infrastructure
@ -211,6 +212,35 @@ (define-public gcc-4.8
(base32
"1j6dwgby4g3p3lz7zkss32ghr45zpdidrg8xvazvn91lqxv25p09"))))))
(define (custom-gcc gcc name languages)
"Return a custom version of GCC that supports LANGUAGES."
(package (inherit gcc)
(name name)
(arguments
(substitute-keyword-arguments `(#:modules ((guix build gnu-build-system)
(guix build utils)
(ice-9 regex)
(srfi srfi-1)
(srfi srfi-26))
,@(package-arguments gcc))
((#:configure-flags flags)
`(cons (string-append "--enable-languages="
,(string-join languages ","))
(remove (cut string-match "--enable-languages.*" <>)
,flags)))))))
(define-public gfortran-4.8
(custom-gcc gcc-4.8 "gfortran" '("fortran")))
(define-public gccgo-4.8
(custom-gcc gcc-4.8 "gccgo" '("go")))
(define-public gcc-objc-4.8
(custom-gcc gcc-4.8 "gcc-objc" '("objc")))
(define-public gcc-objc++-4.8
(custom-gcc gcc-4.8 "gcc-objc++" '("obj-c++")))
(define-public isl
(package
(name "isl")

47
gnu/packages/maths.scm
View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -22,13 +23,16 @@ (define-module (gnu packages maths)
#:renamer (symbol-prefix-proc 'license:))
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system cmake)
#:use-module (guix build-system gnu)
#:use-module (gnu packages compression)
#:use-module ((gnu packages gettext)
#:renamer (symbol-prefix-proc 'gnu:))
#:use-module (gnu packages gcc)
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages readline)
#:use-module (gnu packages xml))
@ -153,3 +157,46 @@ (define-public pspp
from spreadsheets, text files and database sources and it can be output in
text, Postscript, PDF or HTML.")
(license license:gpl3+)))
(define-public lapack
(package
(name "lapack")
(version "3.4.2")
(source
(origin
(method url-fetch)
(uri (string-append "http://www.netlib.org/lapack/lapack-"
version ".tgz"))
(sha256
(base32
"1w7sf8888m7fi2kyx1fzgbm22193l8c2d53m8q1ibhvfy6m5v9k0"))
(snippet
;; Remove non-free files.
;; See <http://icl.cs.utk.edu/lapack-forum/archives/lapack/msg01383.html>.
'(for-each (lambda (file)
(format #t "removing '~a'~%" file)
(delete-file file))
'("lapacke/example/example_DGESV_rowmajor.c"
"lapacke/example/example_ZGESV_rowmajor.c"
"DOCS/psfig.tex")))))
(build-system cmake-build-system)
(home-page "http://www.netlib.org/lapack/")
(inputs `(("fortran" ,gfortran-4.8)
("python" ,python-2)))
(arguments
`(#:modules ((guix build cmake-build-system)
(guix build utils)
(srfi srfi-1))
#:phases (alist-cons-before
'check 'patch-python
(lambda* (#:key inputs #:allow-other-keys)
(let ((python (assoc-ref inputs "python")))
(substitute* "lapack_testing.py"
(("/usr/bin/env python") python))))
%standard-phases)))
(synopsis "Library for numerical linear algebra")
(description
"LAPACK is a Fortran 90 library for solving the most commonly occurring
problems in numerical linear algebra.")
(license (license:bsd-style "file://LICENSE"
"See LICENSE in the distribution."))))

24
gnu/packages/recutils.scm
View file

@ -24,27 +24,31 @@ (define-module (gnu packages recutils)
#:use-module (guix build-system gnu)
#:use-module (gnu packages emacs)
#:use-module (gnu packages check)
#:use-module (gnu packages algebra))
#:use-module (gnu packages algebra)
#:use-module (gnu packages curl)
#:use-module (gnu packages gnupg))
(define-public recutils
(package
(name "recutils")
(version "1.5")
(version "1.6")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/recutils/recutils-"
version ".tar.gz"))
(sha256
(base32
"1v2xzwwwhc5j5kmvg4sv6baxjpsfqh8ln7ilv4mgb1408rs7xmky"))
(patches
(list (search-patch "diffutils-gets-undeclared.patch")))))
"0dxmz73n4qaasqymx97nlw6in98r6lnsfp0586hwkn95d3ll306s"))))
(build-system gnu-build-system)
(inputs `(;; TODO: Enable optional deps when they're packaged.
;; ("curl" ,(nixpkgs-derivation "curl"))
("emacs" ,emacs)
("check" ,check)
("bc" ,bc)))
(native-inputs `(("emacs" ,emacs)
("bc" ,bc)))
;; TODO: Add more optional inputs.
;; FIXME: Our Bash doesn't have development headers (need for the 'readrec'
;; built-in command), but it's not clear how to get them installed.
(inputs `(("curl" ,curl)
("libgcrypt" ,libgcrypt)
("check" ,check)))
(synopsis "Manipulate plain text files as databases")
(description
"Recutils is a set of tools and libraries for creating and

172
gnu/packages/video.scm Normal file
View file

@ -0,0 +1,172 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;;
;;; 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 (gnu packages video)
#:use-module ((guix licenses) #:select (gpl2+))
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages algebra)
#:use-module (gnu packages compression)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages oggvorbis)
#:use-module (gnu packages openssl)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages yasm))
(define-public ffmpeg
(package
(name "ffmpeg")
(version "2.1")
(source (origin
(method url-fetch)
(uri (string-append "http://www.ffmpeg.org/releases/ffmpeg-"
version ".tar.bz2"))
(sha256
(base32
"1pv83nmjgipxwzy5s53834fq0mrqv786zz2w383ki6sfjzyh6rlj"))))
(build-system gnu-build-system)
(inputs
`(("bc" ,bc)
("bzip2" ,bzip2)
("fontconfig" ,fontconfig)
("freetype" ,freetype)
("libtheora" ,libtheora)
("libvorbis" ,libvorbis)
("perl" ,perl)
("pkg-config" ,pkg-config)
("python" ,python-2) ; scripts use interpreter python2
("speex" ,speex)
("yasm" ,yasm)
("zlib", zlib)))
(arguments
`(#:phases
(alist-replace
'configure
;; configure does not work followed by "SHELL=..." and
;; "CONFIG_SHELL=..."; set environment variables instead
(lambda* (#:key outputs configure-flags #:allow-other-keys)
(let ((out (assoc-ref outputs "out")))
(substitute* "configure"
(("#! /bin/sh") (string-append "#!" (which "bash"))))
(setenv "SHELL" (which "bash"))
(setenv "CONFIG_SHELL" (which "bash"))
;; possible additional inputs:
;; --enable-avisynth enable reading of AviSynth script files [no]
;; --enable-frei0r enable frei0r video filtering
;; --enable-ladspa enable LADSPA audio filtering
;; --enable-libaacplus enable AAC+ encoding via libaacplus [no]
;; --enable-libass enable libass subtitles rendering [no]
;; --enable-libbluray enable BluRay reading using libbluray [no]
;; --enable-libcaca enable textual display using libcaca
;; --enable-libcelt enable CELT decoding via libcelt [no]
;; --enable-libcdio enable audio CD grabbing with libcdio
;; --enable-libdc1394 enable IIDC-1394 grabbing using libdc1394
;; and libraw1394 [no]
;; --enable-libfaac enable AAC encoding via libfaac [no]
;; --enable-libfdk-aac enable AAC de/encoding via libfdk-aac [no]
;; --enable-libflite enable flite (voice synthesis) support via libflite [no]
;; --enable-libgme enable Game Music Emu via libgme [no]
;; --enable-libgsm enable GSM de/encoding via libgsm [no]
;; --enable-libiec61883 enable iec61883 via libiec61883 [no]
;; --enable-libilbc enable iLBC de/encoding via libilbc [no]
;; --enable-libmodplug enable ModPlug via libmodplug [no]
;; --enable-libmp3lame enable MP3 encoding via libmp3lame [no]
;; --enable-libnut enable NUT (de)muxing via libnut,
;; native (de)muxer exists [no]
;; --enable-libopencore-amrnb enable AMR-NB de/encoding via libopencore-amrnb [no]
;; --enable-libopencore-amrwb enable AMR-WB decoding via libopencore-amrwb [no]
;; --enable-libopencv enable video filtering via libopencv [no]
;; --enable-libopenjpeg enable JPEG 2000 de/encoding via OpenJPEG [no]
;; --enable-libopus enable Opus decoding via libopus [no]
;; --enable-libpulse enable Pulseaudio input via libpulse [no]
;; --enable-libquvi enable quvi input via libquvi [no]
;; --enable-librtmp enable RTMP[E] support via librtmp [no]
;; --enable-libschroedinger enable Dirac de/encoding via libschroedinger [no]
;; --enable-libshine enable fixed-point MP3 encoding via libshine [no]
;; --enable-libsoxr enable Include libsoxr resampling [no]
;; --enable-libssh enable SFTP protocol via libssh [no]
;; (libssh2 does not work)
;; --enable-libstagefright-h264 enable H.264 decoding via libstagefright [no]
;; --enable-libtwolame enable MP2 encoding via libtwolame [no]
;; --enable-libutvideo enable Ut Video encoding and decoding via libutvideo [no]
;; --enable-libv4l2 enable libv4l2/v4l-utils [no]
;; --enable-libvidstab enable video stabilization using vid.stab [no]
;; --enable-libvo-aacenc enable AAC encoding via libvo-aacenc [no]
;; --enable-libvo-amrwbenc enable AMR-WB encoding via libvo-amrwbenc [no]
;; --enable-libvpx enable VP8 and VP9 de/encoding via libvpx [no]
;; --enable-libwavpack enable wavpack encoding via libwavpack [no]
;; --enable-libx264 enable H.264 encoding via x264 [no]
;; --enable-libxavs enable AVS encoding via xavs [no]
;; --enable-libxvid enable Xvid encoding via xvidcore,
;; native MPEG-4/Xvid encoder exists [no]
;; --enable-libzmq enable message passing via libzmq [no]
;; --enable-libzvbi enable teletext support via libzvbi [no]
;; --enable-openal enable OpenAL 1.1 capture support [no]
;; --enable-opencl enable OpenCL code
;; --enable-x11grab enable X11 grabbing [no]
(zero? (system*
"./configure"
(string-append "--prefix=" out)
"--enable-gpl" ; enable optional gpl licensed parts
"--enable-shared"
"--enable-fontconfig"
;; "--enable-gnutls" ; causes test failures
"--enable-libfreetype"
"--enable-libspeex"
"--enable-libtheora"
"--enable-libvorbis"
;; drop special machine instructions not supported
;; on all instances of the target
,@(if (string-prefix? "x86_64"
(or (%current-target-system)
(%current-system)))
'()
'("--disable-amd3dnow"
"--disable-amd3dnowext"
"--disable-mmx"
"--disable-mmxext"
"--disable-sse"
"--disable-sse2"))
"--disable-altivec"
"--disable-sse3"
"--disable-ssse3"
"--disable-sse4"
"--disable-sse42"
"--disable-avx"
"--disable-fma4"
"--disable-avx2"
"--disable-armv5te"
"--disable-armv6"
"--disable-armv6t2"
"--disable-vfp"
"--disable-neon"
"--disable-vis"
"--disable-mips32r2"
"--disable-mipsdspr1"
"--disable-mipsdspr2"
"--disable-mipsfpu"))))
%standard-phases)))
(home-page "http://www.ffmpeg.org/")
(synopsis "Audio and video framework")
(description "FFmpeg is a complete, cross-platform solution to record,
convert and stream audio and video. It includes the libavcodec
audio/video codec library.")
(license gpl2+)))

81
guix/packages.scm
View file

@ -41,6 +41,9 @@ (define-module (guix packages)
origin-patch-flags
origin-patch-inputs
origin-patch-guile
origin-snippet
origin-modules
origin-imported-modules
base32
<search-path-specification>
@ -107,6 +110,7 @@ (define-record-type* <origin>
(sha256 origin-sha256) ; bytevector
(file-name origin-file-name (default #f)) ; optional file name
(patches origin-patches (default '())) ; list of file names
(snippet origin-snippet (default #f)) ; sexp or #f
(patch-flags origin-patch-flags ; list of strings
(default '("-p1")))
@ -114,6 +118,10 @@ (define-record-type* <origin>
;; used to specify these dependencies when needed.
(patch-inputs origin-patch-inputs ; input list or #f
(default #f))
(modules origin-modules ; list of module names
(default '()))
(imported-modules origin-imported-modules ; list of module names
(default '()))
(patch-guile origin-patch-guile ; package or #f
(default #f)))
@ -272,26 +280,38 @@ (define (default-guile)
(let ((distro (resolve-interface '(gnu packages base))))
(module-ref distro 'guile-final)))
(define* (patch-and-repack store source patches inputs
(define* (patch-and-repack store source patches
#:key
(inputs '())
(snippet #f)
(flags '("-p1"))
(modules '())
(imported-modules '())
(guile-for-build (%guile-for-build))
(system (%current-system)))
"Unpack SOURCE (a derivation), apply all of PATCHES, and repack the tarball
using the tools listed in INPUTS."
"Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
it must be an s-expression that will run from within the directory where
SOURCE was unpacked, after all of PATCHES have been applied. MODULES and
IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
(define source-file-name
;; SOURCE is usually a derivation, but it could be a store file.
(if (derivation? source)
(derivation->output-path source)
source))
(define decompression-type
(let ((out (derivation->output-path source)))
(cond ((string-suffix? "gz" out) "gzip")
((string-suffix? "bz2" out) "bzip2")
((string-suffix? "lz" out) "lzip")
(else "xz"))))
(cond ((string-suffix? "gz" source-file-name) "gzip")
((string-suffix? "bz2" source-file-name) "bzip2")
((string-suffix? "lz" source-file-name) "lzip")
(else "xz")))
(define original-file-name
(let ((out (derivation->output-path source)))
;; Remove the store prefix plus the slash, hash, and hyphen.
(let* ((sans (string-drop out (+ (string-length (%store-prefix)) 1)))
(dash (string-index sans #\-)))
(string-drop sans (+ 1 dash)))))
;; Remove the store prefix plus the slash, hash, and hyphen.
(let* ((sans (string-drop source-file-name
(+ (string-length (%store-prefix)) 1)))
(dash (string-index sans #\-)))
(string-drop sans (+ 1 dash))))
(define patch-inputs
(map (lambda (number patch)
@ -331,7 +351,24 @@ (define (apply-patch input)
(format (current-error-port)
"source is under '~a'~%" directory)
(chdir directory)
(and (every apply-patch ',(map car patch-inputs))
,@(if snippet
`((let ((module (make-fresh-user-module)))
(module-use-interfaces! module
(map resolve-interface
',modules))
(module-define! module '%build-inputs
%build-inputs)
(module-define! module '%outputs %outputs)
((@ (system base compile) compile)
',snippet
#:to 'value
#:opts %auto-compilation-options
#:env module)))
'())
(begin (chdir "..") #t)
(zero? (system* tar "cvfa" out directory))))))))
@ -351,19 +388,21 @@ (define (apply-patch input)
`(("source" ,source)
,@inputs
,@patch-inputs)
#:modules imported-modules
#:guile-for-build guile-for-build)))
(define* (package-source-derivation store source
#:optional (system (%current-system)))
"Return the derivation path for SOURCE, a package source, for SYSTEM."
(match source
(($ <origin> uri method sha256 name ())
;; No patches.
(($ <origin> uri method sha256 name () #f)
;; No patches, no snippet: this is a fixed-output derivation.
(method store uri 'sha256 sha256 name
#:system system))
(($ <origin> uri method sha256 name (patches ...) (flags ...)
inputs guile-for-build)
;; One or more patches.
(($ <origin> uri method sha256 name (patches ...) snippet
(flags ...) inputs (modules ...) (imported-modules ...)
guile-for-build)
;; Patches and/or a snippet.
(let ((source (method store uri 'sha256 sha256 name
#:system system))
(guile (match (or guile-for-build (%guile-for-build)
@ -372,9 +411,13 @@ (define* (package-source-derivation store source
(package-derivation store p system))
((? derivation? drv)
drv))))
(patch-and-repack store source patches inputs
(patch-and-repack store source patches
#:inputs inputs
#:snippet snippet
#:flags flags
#:system system
#:modules modules
#:imported-modules modules
#:guile-for-build guile)))
((and (? string?) (? store-path?) file)
file)

347
guix/profiles.scm Normal file
View file

@ -0,0 +1,347 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix profiles)
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 ftw)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:export (manifest make-manifest
manifest?
manifest-entries
<manifest-entry> ; FIXME: eventually make it internal
manifest-entry
manifest-entry?
manifest-entry-name
manifest-entry-version
manifest-entry-output
manifest-entry-path
manifest-entry-dependencies
manifest-pattern
manifest-pattern?
read-manifest
write-manifest
manifest-remove
manifest-installed?
manifest-matching-entries
manifest=?
profile-manifest
profile-derivation
generation-number
generation-numbers
previous-generation-number
generation-time
generation-file-name))
;;; Commentary:
;;;
;;; Tools to create and manipulate profiles---i.e., the representation of a
;;; set of installed packages.
;;;
;;; Code:
;;;
;;; Manifests.
;;;
(define-record-type <manifest>
(manifest entries)
manifest?
(entries manifest-entries)) ; list of <manifest-entry>
;; Convenient alias, to avoid name clashes.
(define make-manifest manifest)
(define-record-type* <manifest-entry> manifest-entry
make-manifest-entry
manifest-entry?
(name manifest-entry-name) ; string
(version manifest-entry-version) ; string
(output manifest-entry-output ; string
(default "out"))
(path manifest-entry-path) ; store path
(dependencies manifest-entry-dependencies ; list of store paths
(default '()))
(inputs manifest-entry-inputs ; list of inputs to build
(default '()))) ; this entry
(define-record-type* <manifest-pattern> manifest-pattern
make-manifest-pattern
manifest-pattern?
(name manifest-pattern-name) ; string
(version manifest-pattern-version ; string | #f
(default #f))
(output manifest-pattern-output ; string | #f
(default "out")))
(define (profile-manifest profile)
"Return the PROFILE's manifest."
(let ((file (string-append profile "/manifest")))
(if (file-exists? file)
(call-with-input-file file read-manifest)
(manifest '()))))
(define (manifest->sexp manifest)
"Return a representation of MANIFEST as an sexp."
(define (entry->sexp entry)
(match entry
(($ <manifest-entry> name version path output (deps ...))
(list name version path output deps))))
(match manifest
(($ <manifest> (entries ...))
`(manifest (version 1)
(packages ,(map entry->sexp entries))))))
(define (sexp->manifest sexp)
"Parse SEXP as a manifest."
(match sexp
(('manifest ('version 0)
('packages ((name version output path) ...)))
(manifest
(map (lambda (name version output path)
(manifest-entry
(name name)
(version version)
(output output)
(path path)))
name version output path)))
;; Version 1 adds a list of propagated inputs to the
;; name/version/output/path tuples.
(('manifest ('version 1)
('packages ((name version output path deps) ...)))
(manifest
(map (lambda (name version output path deps)
(manifest-entry
(name name)
(version version)
(output output)
(path path)
(dependencies deps)))
name version output path deps)))
(_
(error "unsupported manifest format" manifest))))
(define (read-manifest port)
"Return the packages listed in MANIFEST."
(sexp->manifest (read port)))
(define (write-manifest manifest port)
"Write MANIFEST to PORT."
(write (manifest->sexp manifest) port))
(define (entry-predicate pattern)
"Return a procedure that returns #t when passed a manifest entry that
matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they
are ignored."
(match pattern
(($ <manifest-pattern> name version output)
(match-lambda
(($ <manifest-entry> entry-name entry-version entry-output)
(and (string=? entry-name name)
(or (not entry-output) (not output)
(string=? entry-output output))
(or (not version)
(string=? entry-version version))))))))
(define (manifest-remove manifest patterns)
"Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS
must be a manifest-pattern."
(define (remove-entry pattern lst)
(remove (entry-predicate pattern) lst))
(make-manifest (fold remove-entry
(manifest-entries manifest)
patterns)))
(define (manifest-installed? manifest pattern)
"Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
#f otherwise."
(->bool (find (entry-predicate pattern)
(manifest-entries manifest))))
(define (manifest-matching-entries manifest patterns)
"Return all the entries of MANIFEST that match one of the PATTERNS."
(define predicates
(map entry-predicate patterns))
(define (matches? entry)
(any (lambda (pred)
(pred entry))
predicates))
(filter matches? (manifest-entries manifest)))
(define (manifest=? m1 m2)
"Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in
that the 'inputs' field is ignored for the comparison, since it is know to
have no effect on the manifest contents."
(equal? (manifest->sexp m1)
(manifest->sexp m2)))
;;;
;;; Profiles.
;;;
(define* (lower-input store input #:optional (system (%current-system)))
"Lower INPUT so that it contains derivations instead of packages."
(match input
((name (? package? package))
`(,name ,(package-derivation store package system)))
((name (? package? package) output)
`(,name ,(package-derivation store package system)
,output))
(_ input)))
(define (profile-derivation store manifest)
"Return a derivation that builds a profile (aka. 'user environment') with
the given MANIFEST."
(define builder
`(begin
(use-modules (ice-9 pretty-print)
(guix build union))
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
(let ((output (assoc-ref %outputs "out"))
(inputs (map cdr %build-inputs)))
(format #t "building profile '~a' with ~a packages...~%"
output (length inputs))
(union-build output inputs
#:log-port (%make-void-port "w"))
(call-with-output-file (string-append output "/manifest")
(lambda (p)
(pretty-print ',(manifest->sexp manifest) p))))))
(build-expression->derivation store "profile"
(%current-system)
builder
(append-map (match-lambda
(($ <manifest-entry> name version
output path deps (inputs ..1))
(map (cute lower-input store <>)
inputs))
(($ <manifest-entry> name version
output path deps)
;; Assume PATH and DEPS are
;; already valid.
`((,name ,path) ,@deps)))
(manifest-entries manifest))
#:modules '((guix build union))))
(define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number."
(make-regexp (string-append "^" (regexp-quote (basename profile))
"-([0-9]+)")))
(define (generation-number profile)
"Return PROFILE's number or 0. An absolute file name must be used."
(or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
(basename (readlink profile))))
(compose string->number (cut match:substring <> 1)))
0))
(define (generation-numbers profile)
"Return the sorted list of generation numbers of PROFILE, or '(0) if no
former profiles were found."
(define* (scandir name #:optional (select? (const #t))
(entry<? (@ (ice-9 i18n) string-locale<?)))
;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
(define (enter? dir stat result)
(and stat (string=? dir name)))
(define (visit basename result)
(if (select? basename)
(cons basename result)
result))
(define (leaf name stat result)
(and result
(visit (basename name) result)))
(define (down name stat result)
(visit "." '()))
(define (up name stat result)
(visit ".." result))
(define (skip name stat result)
;; All the sub-directories are skipped.
(visit (basename name) result))
(define (error name* stat errno result)
(if (string=? name name*) ; top-level NAME is unreadable
result
(visit (basename name*) result)))
(and=> (file-system-fold enter? leaf down up skip error #f name lstat)
(lambda (files)
(sort files entry<?))))
(match (scandir (dirname profile)
(cute regexp-exec (profile-regexp profile) <>))
(#f ; no profile directory
'(0))
(() ; no profiles
'(0))
((profiles ...) ; former profiles around
(sort (map (compose string->number
(cut match:substring <> 1)
(cute regexp-exec (profile-regexp profile) <>))
profiles)
<))))
(define (previous-generation-number profile number)
"Return the number of the generation before generation NUMBER of
PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
case when generations have been deleted (there are \"holes\")."
(fold (lambda (candidate highest)
(if (and (< candidate number) (> candidate highest))
candidate
highest))
0
(generation-numbers profile)))
(define (generation-file-name profile generation)
"Return the file name for PROFILE's GENERATION."
(format #f "~a-~a-link" profile generation))
(define (generation-time profile number)
"Return the creation time of a generation in the UTC format."
(make-time time-utc 0
(stat:ctime (stat (generation-file-name profile number)))))
;;; profiles.scm ends here

387
guix/scripts/package.scm
View file

@ -23,22 +23,19 @@ (define-module (guix scripts package)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix profiles)
#:use-module (guix utils)
#:use-module (guix config)
#:use-module (guix records)
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
#:use-module ((guix ftp-client) #:select (ftp-open))
#:use-module (ice-9 ftw)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:use-module (gnu packages)
#:use-module ((gnu packages base) #:select (guile-final))
@ -51,7 +48,7 @@ (define %store
;;;
;;; User profile.
;;; Profiles.
;;;
(define %user-profile-directory
@ -69,240 +66,6 @@ (define %current-profile
;; coexist with Nix profiles.
(string-append %profile-directory "/guix-profile"))
;;;
;;; Manifests.
;;;
(define-record-type <manifest>
(manifest entries)
manifest?
(entries manifest-entries)) ; list of <manifest-entry>
;; Convenient alias, to avoid name clashes.
(define make-manifest manifest)
(define-record-type* <manifest-entry> manifest-entry
make-manifest-entry
manifest-entry?
(name manifest-entry-name) ; string
(version manifest-entry-version) ; string
(output manifest-entry-output ; string
(default "out"))
(path manifest-entry-path) ; store path
(dependencies manifest-entry-dependencies ; list of store paths
(default '()))
(inputs manifest-entry-inputs ; list of inputs to build
(default '()))) ; this entry
(define (profile-manifest profile)
"Return the PROFILE's manifest."
(let ((file (string-append profile "/manifest")))
(if (file-exists? file)
(call-with-input-file file read-manifest)
(manifest '()))))
(define (manifest->sexp manifest)
"Return a representation of MANIFEST as an sexp."
(define (entry->sexp entry)
(match entry
(($ <manifest-entry> name version path output (deps ...))
(list name version path output deps))))
(match manifest
(($ <manifest> (entries ...))
`(manifest (version 1)
(packages ,(map entry->sexp entries))))))
(define (sexp->manifest sexp)
"Parse SEXP as a manifest."
(match sexp
(('manifest ('version 0)
('packages ((name version output path) ...)))
(manifest
(map (lambda (name version output path)
(manifest-entry
(name name)
(version version)
(output output)
(path path)))
name version output path)))
;; Version 1 adds a list of propagated inputs to the
;; name/version/output/path tuples.
(('manifest ('version 1)
('packages ((name version output path deps) ...)))
(manifest
(map (lambda (name version output path deps)
(manifest-entry
(name name)
(version version)
(output output)
(path path)
(dependencies deps)))
name version output path deps)))
(_
(error "unsupported manifest format" manifest))))
(define (read-manifest port)
"Return the packages listed in MANIFEST."
(sexp->manifest (read port)))
(define (write-manifest manifest port)
"Write MANIFEST to PORT."
(write (manifest->sexp manifest) port))
(define (remove-manifest-entry name lst)
"Remove the manifest entry named NAME from LST."
(remove (match-lambda
(($ <manifest-entry> entry-name)
(string=? name entry-name)))
lst))
(define (manifest-remove manifest names)
"Remove entries for each of NAMES from MANIFEST."
(make-manifest (fold remove-manifest-entry
(manifest-entries manifest)
names)))
(define (manifest-installed? manifest name)
"Return #t if MANIFEST has an entry for NAME, #f otherwise."
(define (->bool x)
(not (not x)))
(->bool (find (match-lambda
(($ <manifest-entry> entry-name)
(string=? entry-name name)))
(manifest-entries manifest))))
(define (manifest=? m1 m2)
"Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in
that the 'inputs' field is ignored for the comparison, since it is know to
have no effect on the manifest contents."
(equal? (manifest->sexp m1)
(manifest->sexp m2)))
;;;
;;; Profiles.
;;;
(define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number."
(make-regexp (string-append "^" (regexp-quote (basename profile))
"-([0-9]+)")))
(define (generation-numbers profile)
"Return the sorted list of generation numbers of PROFILE, or '(0) if no
former profiles were found."
(define* (scandir name #:optional (select? (const #t))
(entry<? (@ (ice-9 i18n) string-locale<?)))
;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
(define (enter? dir stat result)
(and stat (string=? dir name)))
(define (visit basename result)
(if (select? basename)
(cons basename result)
result))
(define (leaf name stat result)
(and result
(visit (basename name) result)))
(define (down name stat result)
(visit "." '()))
(define (up name stat result)
(visit ".." result))
(define (skip name stat result)
;; All the sub-directories are skipped.
(visit (basename name) result))
(define (error name* stat errno result)
(if (string=? name name*) ; top-level NAME is unreadable
result
(visit (basename name*) result)))
(and=> (file-system-fold enter? leaf down up skip error #f name lstat)
(lambda (files)
(sort files entry<?))))
(match (scandir (dirname profile)
(cute regexp-exec (profile-regexp profile) <>))
(#f ; no profile directory
'(0))
(() ; no profiles
'(0))
((profiles ...) ; former profiles around
(sort (map (compose string->number
(cut match:substring <> 1)
(cute regexp-exec (profile-regexp profile) <>))
profiles)
<))))
(define (previous-generation-number profile number)
"Return the number of the generation before generation NUMBER of
PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
case when generations have been deleted (there are \"holes\")."
(fold (lambda (candidate highest)
(if (and (< candidate number) (> candidate highest))
candidate
highest))
0
(generation-numbers profile)))
(define (profile-derivation store manifest)
"Return a derivation that builds a profile (aka. 'user environment') with
the given MANIFEST."
(define builder
`(begin
(use-modules (ice-9 pretty-print)
(guix build union))
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
(let ((output (assoc-ref %outputs "out"))
(inputs (map cdr %build-inputs)))
(format #t "building profile '~a' with ~a packages...~%"
output (length inputs))
(union-build output inputs
#:log-port (%make-void-port "w"))
(call-with-output-file (string-append output "/manifest")
(lambda (p)
(pretty-print ',(manifest->sexp manifest) p))))))
(build-expression->derivation store "profile"
(%current-system)
builder
(append-map (match-lambda
(($ <manifest-entry> name version
output path deps (inputs ..1))
(map (cute lower-input
(%store) <>)
inputs))
(($ <manifest-entry> name version
output path deps)
;; Assume PATH and DEPS are
;; already valid.
`((,name ,path) ,@deps)))
(manifest-entries manifest))
#:modules '((guix build union))))
(define (generation-number profile)
"Return PROFILE's number or 0. An absolute file name must be used."
(or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
(basename (readlink profile))))
(compose string->number (cut match:substring <> 1)))
0))
(define (generation-file-name profile generation)
"Return the file name for PROFILE's GENERATION."
(format #f "~a-~a-link" profile generation))
(define (link-to-empty-profile generation)
"Link GENERATION, a string, to the empty profile."
(let* ((drv (profile-derivation (%store) (manifest '())))
@ -340,11 +103,6 @@ (define (roll-back profile)
(else
(switch-to-previous-generation profile))))) ; anything else
(define (generation-time profile number)
"Return the creation time of a generation in the UTC format."
(make-time time-utc 0
(stat:ctime (stat (generation-file-name profile number)))))
(define* (matching-generations str #:optional (profile %current-profile)
#:key (duration-relation <=))
"Return the list of available generations matching a pattern in STR. See
@ -411,6 +169,50 @@ (define generation-ctime-alist
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 path _) ..1)
(let ((len (length name))
(install (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 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.
;;;
(define (find-packages-by-description rx)
"Return the list of packages whose name, synopsis, or description matches
RX."
@ -437,16 +239,6 @@ (define matches?
(package-name p2))))
same-location?))
(define* (lower-input store input #:optional (system (%current-system)))
"Lower INPUT so that it contains derivations instead of packages."
(match input
((name (? package? package))
`(,name ,(package-derivation store package system)))
((name (? package? package) output)
`(,name ,(package-derivation store package system)
,output))
(_ input)))
(define (input->name+path input)
"Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
(let loop ((input input))
@ -500,11 +292,6 @@ (define-syntax-rule (waiting exp fmt rest ...)
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f))))
;;;
;;; Package specifications.
;;;
(define newest-available-packages
(memoize find-newest-available-packages))
@ -536,13 +323,8 @@ (define (ensure-output p sub-drv)
(package-full-name p)
sub-drv)))
(let*-values (((name sub-drv)
(match (string-rindex spec #\:)
(#f (values spec output))
(colon (values (substring spec 0 colon)
(substring spec (+ 1 colon))))))
((name version)
(package-name->name+version name)))
(let-values (((name version sub-drv)
(package-specification->name+version+output spec)))
(match (find-best-packages-by-name name version)
((p)
(values p (ensure-output p sub-drv)))
@ -910,6 +692,22 @@ (define to-install
(append to-upgrade to-install))
(define (options->removable options manifest)
"Given options, return the list of manifest patterns of packages to be
removed from MANIFEST."
(filter-map (match-lambda
(('remove . spec)
(call-with-values
(lambda ()
(package-specification->name+version+output spec))
(lambda (name version output)
(manifest-pattern
(name name)
(version version)
(output output)))))
(_ #f))
options))
;;;
;;; Entry point.
@ -989,44 +787,6 @@ (define (same-package? entry name output)
(and (equal? name entry-name)
(equal? output entry-output)))))
(define (show-what-to-remove/install remove install dry-run?)
;; Tell the user what's going to happen in high-level terms.
;; TODO: Report upgrades more clearly.
(match remove
((($ <manifest-entry> name version _ path _) ..1)
(let ((len (length name))
(remove (map (cut format #f " ~a-~a\t~a" <> <> <>)
name version 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 path _) ..1)
(let ((len (length name))
(install (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 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)))
(define current-generation-number
(generation-number profile))
@ -1095,16 +855,10 @@ (define (delete-generation number)
opts))
(else
(let* ((manifest (profile-manifest profile))
(install* (options->installable opts manifest))
(remove (filter-map (match-lambda
(('remove . package)
package)
(_ #f))
opts))
(remove* (filter (cut manifest-installed? manifest <>)
remove))
(install (options->installable opts manifest))
(remove (options->removable opts manifest))
(entries
(append install*
(append install
(fold (lambda (package result)
(match package
(($ <manifest-entry> name _ out _ ...)
@ -1114,7 +868,7 @@ (define (delete-generation number)
result))))
(manifest-entries
(manifest-remove manifest remove))
install*)))
install)))
(new (make-manifest entries)))
(when (equal? profile %current-profile)
@ -1122,8 +876,9 @@ (define (delete-generation number)
(if (manifest=? new manifest)
(format (current-error-port) (_ "nothing to be done~%"))
(let ((prof-drv (profile-derivation (%store) new)))
(show-what-to-remove/install remove* install* dry-run?)
(let ((prof-drv (profile-derivation (%store) new))
(remove (manifest-matching-entries manifest remove)))
(show-what-to-remove/install remove install dry-run?)
(show-what-to-build (%store) (list prof-drv)
#:use-substitutes?
(assoc-ref opts 'substitutes?)

36
guix/ui.scm
View file

@ -52,6 +52,7 @@ (define-module (guix ui)
fill-paragraph
string->recutils
package->recutils
package-specification->name+version+output
string->generations
string->duration
args-fold*
@ -136,6 +137,11 @@ (define* (show-version-and-exit #:optional (command (car (command-line))))
"Display version information for COMMAND and `(exit 0)'."
(simple-format #t "~a (~a) ~a~%"
command %guix-package-name %guix-version)
(display (_ "Copyright (C) 2013 the Guix authors
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.
"))
(exit 0))
(define (show-bug-report-information)
@ -358,6 +364,11 @@ (define (maybe-break chr result)
((_ _ chars)
(list->string (reverse chars)))))
;;;
;;; Packages.
;;;
(define (string->recutils str)
"Return a version of STR where newlines have been replaced by newlines
followed by \"+ \", which makes for a valid multi-line field value in the
@ -472,6 +483,31 @@ (define (hours->duration hours match)
(hours->duration (* 24 30) match)))
(else #f)))
(define* (package-specification->name+version+output spec
#:optional (output "out"))
"Parse package specification SPEC and return three value: the specified
package name, version number (or #f), and output name (or OUTPUT). SPEC may
optionally contain a version number and an output name, as in these examples:
guile
guile-2.0.9
guile:debug
guile-2.0.9:debug
"
(let*-values (((name sub-drv)
(match (string-rindex spec #\:)
(#f (values spec output))
(colon (values (substring spec 0 colon)
(substring spec (+ 1 colon))))))
((name version)
(package-name->name+version name)))
(values name version sub-drv)))
;;;
;;; Command-line option processing.
;;;
(define (args-fold* options unrecognized-option-proc operand-proc . seeds)
"A wrapper on top of `args-fold' that does proper user-facing error
reporting."

25
tests/derivations.scm
View file

@ -125,7 +125,7 @@ (define prefix-len (string-length dir))
#:env-vars '(("HOME" . "/homeless")
("zzz" . "Z!")
("AAA" . "A!"))
#:inputs `((,builder))))
#:inputs `((,%bash) (,builder))))
(succeeded?
(build-derivations %store (list drv))))
(and succeeded?
@ -149,7 +149,8 @@ (define prefix-len (string-length dir))
;; builder.
#:env-vars `(("in" . ,input*))
#:inputs `((,builder)
#:inputs `((,%bash)
(,builder)
(,input))))) ; ← local file name
(and (build-derivations %store (list drv))
;; Note: we can't compare the files because the above trick alters
@ -211,11 +212,11 @@ (define prefix-len (string-length dir))
(final1 (derivation %store "final"
%bash `(,builder3)
#:env-vars `(("in" . ,fixed-out))
#:inputs `((,builder3) (,fixed1))))
#:inputs `((,%bash) (,builder3) (,fixed1))))
(final2 (derivation %store "final"
%bash `(,builder3)
#:env-vars `(("in" . ,fixed-out))
#:inputs `((,builder3) (,fixed2))))
#:inputs `((,%bash) (,builder3) (,fixed2))))
(succeeded? (build-derivations %store
(list final1 final2))))
(and succeeded?
@ -231,7 +232,7 @@ (define prefix-len (string-length dir))
#:env-vars '(("HOME" . "/homeless")
("zzz" . "Z!")
("AAA" . "A!"))
#:inputs `((,builder))
#:inputs `((,%bash) (,builder))
#:outputs '("out" "second")))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
@ -251,7 +252,7 @@ (define prefix-len (string-length dir))
'()))
(drv (derivation %store "fixed"
%bash `(,builder)
#:inputs `((,builder))
#:inputs `((,%bash) (,builder))
#:outputs '("out" "AAA")))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
@ -285,7 +286,7 @@ (define prefix-len (string-length dir))
'()))
(mdrv (derivation %store "multiple-output"
%bash `(,builder1)
#:inputs `((,builder1))
#:inputs `((,%bash) (,builder1))
#:outputs '("out" "two")))
(builder2 (add-text-to-store %store "my-mo-user-builder.sh"
"read x < $one;
@ -300,7 +301,8 @@ (define prefix-len (string-length dir))
("two"
. ,(derivation->output-path
mdrv "two")))
#:inputs `((,builder2)
#:inputs `((,%bash)
(,builder2)
;; two occurrences of MDRV:
(,mdrv)
(,mdrv "two")))))
@ -417,8 +419,8 @@ (define %coreutils
(let* ((store (let ((s (open-connection)))
(set-build-options s #:max-silent-time 1)
s))
(builder '(sleep 100))
(drv (build-expression->derivation %store "silent"
(builder '(begin (sleep 100) (mkdir %output) #t))
(drv (build-expression->derivation store "silent"
(%current-system)
builder '()))
(out-path (derivation->output-path drv)))
@ -426,7 +428,8 @@ (define %coreutils
(and (string-contains (nix-protocol-error-message c)
"failed")
(not (valid-path? store out-path)))))
(build-derivations %store (list drv)))))
(build-derivations store (list drv))
#f)))
(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
(let ((drv (build-expression->derivation %store "fail" (%current-system)

60
tests/packages.scm
View file

@ -20,6 +20,7 @@
(define-module (test-packages)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix hash)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix build-system)
@ -121,6 +122,65 @@ (define read-at
(package-source package))))
(string=? file source)))
(test-equal "package-source-derivation, snippet"
"OK"
(let* ((file (search-bootstrap-binary "guile-2.0.7.tar.xz"
(%current-system)))
(sha256 (call-with-input-file file port-sha256))
(fetch (lambda* (store url hash-algo hash
#:optional name #:key system)
(pk 'fetch url hash-algo hash name system)
(add-to-store store (basename url) #f "sha256" url)))
(source (bootstrap-origin
(origin
(method fetch)
(uri file)
(sha256 sha256)
(patch-inputs
`(("tar" ,%bootstrap-coreutils&co)
("xz" ,%bootstrap-coreutils&co)
("patch" ,%bootstrap-coreutils&co)))
(patch-guile %bootstrap-guile)
(modules '((guix build utils)))
(imported-modules modules)
(snippet '(begin
;; We end up in 'bin', because it's the first
;; directory, alphabetically. Not a very good
;; example but hey.
(chmod "." #o777)
(symlink "guile" "guile-rocks")
(copy-recursively "../share/guile/2.0/scripts"
"scripts")
;; These variables must exist.
(pk %build-inputs %outputs))))))
(package (package (inherit (dummy-package "with-snippet"))
(source source)
(build-system trivial-build-system)
(inputs
`(("tar" ,(search-bootstrap-binary "tar"
(%current-system)))
("xz" ,(search-bootstrap-binary "xz"
(%current-system)))))
(arguments
`(#:guile ,%bootstrap-guile
#:builder
(let ((tar (assoc-ref %build-inputs "tar"))
(xz (assoc-ref %build-inputs "xz"))
(source (assoc-ref %build-inputs "source")))
(and (zero? (system* tar "xvf" source
"--use-compress-program" xz))
(string=? "guile" (readlink "bin/guile-rocks"))
(file-exists? "bin/scripts/compile.scm")
(let ((out (assoc-ref %outputs "out")))
(call-with-output-file out
(lambda (p)
(display "OK" p))))))))))
(drv (package-derivation %store package))
(out (derivation->output-path drv)))
(and (build-derivations %store (list (pk 'snippet-drv drv)))
(call-with-input-file out get-string-all))))
(test-assert "return value"
(let ((drv (package-derivation %store (dummy-package "p"))))
(and (derivation? drv)

97
tests/profiles.scm Normal file
View file

@ -0,0 +1,97 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 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 (test-profiles)
#:use-module (guix profiles)
#:use-module (ice-9 match)
#:use-module (srfi srfi-64))
;; Test the (guix profile) module.
;; Example manifest entries.
(define guile-2.0.9
(manifest-entry
(name "guile")
(version "2.0.9")
(path "/gnu/store/...")
(output "out")))
(define guile-2.0.9:debug
(manifest-entry (inherit guile-2.0.9)
(output "debug")))
(test-begin "profiles")
(test-assert "manifest-installed?"
(let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
(and (manifest-installed? m (manifest-pattern (name "guile")))
(manifest-installed? m (manifest-pattern
(name "guile") (output "debug")))
(manifest-installed? m (manifest-pattern
(name "guile") (output "out")
(version "2.0.9")))
(not (manifest-installed?
m (manifest-pattern (name "guile") (version "1.8.8"))))
(not (manifest-installed?
m (manifest-pattern (name "guile") (output "foobar")))))))
(test-assert "manifest-matching-entries"
(let* ((e (list guile-2.0.9 guile-2.0.9:debug))
(m (manifest e)))
(and (null? (manifest-matching-entries m
(list (manifest-pattern
(name "python")))))
(equal? e
(manifest-matching-entries m
(list (manifest-pattern
(name "guile")
(output #f)))))
(equal? (list guile-2.0.9)
(manifest-matching-entries m
(list (manifest-pattern
(name "guile")
(version "2.0.9"))))))))
(test-assert "manifest-remove"
(let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
(m1 (manifest-remove m0
(list (manifest-pattern (name "guile")))))
(m2 (manifest-remove m1
(list (manifest-pattern (name "guile"))))) ; same
(m3 (manifest-remove m2
(list (manifest-pattern
(name "guile") (output "debug")))))
(m4 (manifest-remove m3
(list (manifest-pattern (name "guile"))))))
(match (manifest-entries m2)
((($ <manifest-entry> "guile" "2.0.9" "debug"))
(and (equal? m1 m2)
(null? (manifest-entries m3))
(null? (manifest-entries m4)))))))
(test-end "profiles")
(exit (= (test-runner-fail-count (test-runner-current)) 0))
;;; Local Variables:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
;;; End:

17
tests/ui.scm
View file

@ -65,6 +65,23 @@ (define %paragraph
10)
#\newline))
(test-equal "package-specification->name+version+output"
'(("guile" #f "out")
("guile" "2.0.9" "out")
("guile" #f "debug")
("guile" "2.0.9" "debug")
("guile-cairo" "1.4.1" "out"))
(map (lambda (spec)
(call-with-values
(lambda ()
(package-specification->name+version+output spec))
list))
'("guile"
"guile-2.0.9"
"guile:debug"
"guile-2.0.9:debug"
"guile-cairo-1.4.1")))
(test-equal "integer"
'(1)
(string->generations "1"))