me
/
guix
Archived
1
0
Fork 0
Code

Merge branch 'master' into core-updates 

Conflicts:
	guix/packages.scm
master
Ludovic Courtès 2013-11-08 21:58:09 +01:00
parent 7a78cc7af2 6a9957545c
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 'substitute* 'scheme-indent-function 1))
(eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'with-directory-excursion 'scheme-indent-function 1))
(eval . (put 'package 'scheme-indent-function 0)) (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 'substitute-keyword-arguments 'scheme-indent-function 1))
(eval . (put 'with-error-handling 'scheme-indent-function 0)) (eval . (put 'with-error-handling 'scheme-indent-function 0))
(eval . (put 'with-mutex 'scheme-indent-function 1)) (eval . (put 'with-mutex 'scheme-indent-function 1))

4
Makefile.am
View File

@ -41,6 +41,7 @@ MODULES = \
guix/hash.scm \ guix/hash.scm \
guix/utils.scm \ guix/utils.scm \
guix/monads.scm \ guix/monads.scm \
guix/profiles.scm \
guix/serialization.scm \ guix/serialization.scm \
guix/nar.scm \ guix/nar.scm \
guix/derivations.scm \ guix/derivations.scm \
@ -114,7 +115,8 @@ SCM_TESTS = \
tests/store.scm \ tests/store.scm \
tests/monads.scm \ tests/monads.scm \
tests/nar.scm \ tests/nar.scm \
tests/union.scm tests/union.scm \
tests/profiles.scm
SH_TESTS = \ SH_TESTS = \
tests/guix-build.sh \ 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}). the Daemon, build users}).
@item --no-substitutes @item --no-substitutes
@cindex substitutes
Do not use substitutes for build products. That is, always build things Do not use substitutes for build products. That is, always build things
locally instead of allowing downloads of pre-built binaries. 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 @item --cache-failures
Cache build failures. By default, only successful builds are cached. 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 given package installation matches the current state of their
distribution, and helps maximize @dfn{reproducibility}. distribution, and helps maximize @dfn{reproducibility}.
@cindex substitute
This foundation allows Guix to support @dfn{transparent binary/source This foundation allows Guix to support @dfn{transparent binary/source
deployment}. When a pre-built binary for a @file{/nix/store} path is deployment}. When a pre-built binary for a @file{/nix/store} path is
available from an external source, Guix just downloads it; otherwise, it available from an external source---a @dfn{substitute}, Guix just
builds the package from source, locally. 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 @node Invoking guix package
@section Invoking @command{guix package} @section Invoking @command{guix package}
@ -540,6 +557,11 @@ multiple-output package.
@itemx -r @var{package} @itemx -r @var{package}
Remove @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}] @item --upgrade[=@var{regexp}]
@itemx -u [@var{regexp}] @itemx -u [@var{regexp}]
Upgrade all the installed packages. When @var{regexp} is specified, upgrade 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. packages locally.
@item --no-substitutes @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}). Same as for @command{guix build} (@pxref{Invoking guix build}).
@item --verbose @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 @code{guix download} (@pxref{Invoking guix download}) and @code{guix
hash} (@pxref{Invoking guix hash}). 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 @item
@cindex GNU Build System @cindex GNU Build System
The @code{build-system} field is set to @var{gnu-build-system}. The 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 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. @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} @item --system=@var{system}
@itemx -s @var{system} @itemx -s @var{system}
Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of 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. packages locally.
@item --no-substitutes @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} @item --max-silent-time=@var{seconds}
When the build or substitution process remains silent for more than 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 reject non-free firmware, recommendations of non-free software, and
discuss ways to deal with trademarks and patents. 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 @node Package Naming
@subsection Package Naming @subsection Package Naming

1
gnu-system.am
View File

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

4
gnu/packages/cmake.scm
View File

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

30
gnu/packages/gcc.scm
View File

@ -27,6 +27,7 @@
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix download) #:use-module (guix download)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix utils)
#:use-module (ice-9 regex)) #:use-module (ice-9 regex))
(define %gcc-infrastructure (define %gcc-infrastructure
@ -211,6 +212,35 @@ Go. It also includes standard libraries for these languages.")
(base32 (base32
"1j6dwgby4g3p3lz7zkss32ghr45zpdidrg8xvazvn91lqxv25p09")))))) "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 (define-public isl
(package (package
(name "isl") (name "isl")

47
gnu/packages/maths.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -22,13 +23,16 @@
#:renamer (symbol-prefix-proc 'license:)) #:renamer (symbol-prefix-proc 'license:))
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix download) #:use-module (guix download)
#:use-module (guix build-system cmake)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
#:use-module ((gnu packages gettext) #:use-module ((gnu packages gettext)
#:renamer (symbol-prefix-proc 'gnu:)) #:renamer (symbol-prefix-proc 'gnu:))
#:use-module (gnu packages gcc)
#:use-module (gnu packages multiprecision) #:use-module (gnu packages multiprecision)
#:use-module (gnu packages perl) #:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config) #:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages readline) #:use-module (gnu packages readline)
#:use-module (gnu packages xml)) #:use-module (gnu packages xml))
@ -153,3 +157,46 @@ interoperate with Gnumeric, LibreOffice and OpenOffice. Data can be imported
from spreadsheets, text files and database sources and it can be output in from spreadsheets, text files and database sources and it can be output in
text, Postscript, PDF or HTML.") text, Postscript, PDF or HTML.")
(license license:gpl3+))) (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 @@
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (gnu packages emacs) #:use-module (gnu packages emacs)
#:use-module (gnu packages check) #: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 (define-public recutils
(package (package
(name "recutils") (name "recutils")
(version "1.5") (version "1.6")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "mirror://gnu/recutils/recutils-" (uri (string-append "mirror://gnu/recutils/recutils-"
version ".tar.gz")) version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"1v2xzwwwhc5j5kmvg4sv6baxjpsfqh8ln7ilv4mgb1408rs7xmky")) "0dxmz73n4qaasqymx97nlw6in98r6lnsfp0586hwkn95d3ll306s"))))
(patches
(list (search-patch "diffutils-gets-undeclared.patch")))))
(build-system gnu-build-system) (build-system gnu-build-system)
(inputs `(;; TODO: Enable optional deps when they're packaged. (native-inputs `(("emacs" ,emacs)
;; ("curl" ,(nixpkgs-derivation "curl")) ("bc" ,bc)))
("emacs" ,emacs)
("check" ,check) ;; TODO: Add more optional inputs.
("bc" ,bc))) ;; 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") (synopsis "Manipulate plain text files as databases")
(description (description
"Recutils is a set of tools and libraries for creating and "Recutils is a set of tools and libraries for creating and

172
gnu/packages/video.scm 100644
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 @@
origin-patch-flags origin-patch-flags
origin-patch-inputs origin-patch-inputs
origin-patch-guile origin-patch-guile
origin-snippet
origin-modules
origin-imported-modules
base32 base32
<search-path-specification> <search-path-specification>
@ -107,6 +110,7 @@
(sha256 origin-sha256) ; bytevector (sha256 origin-sha256) ; bytevector
(file-name origin-file-name (default #f)) ; optional file name (file-name origin-file-name (default #f)) ; optional file name
(patches origin-patches (default '())) ; list of file names (patches origin-patches (default '())) ; list of file names
(snippet origin-snippet (default #f)) ; sexp or #f
(patch-flags origin-patch-flags ; list of strings (patch-flags origin-patch-flags ; list of strings
(default '("-p1"))) (default '("-p1")))
@ -114,6 +118,10 @@
;; used to specify these dependencies when needed. ;; used to specify these dependencies when needed.
(patch-inputs origin-patch-inputs ; input list or #f (patch-inputs origin-patch-inputs ; input list or #f
(default #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 (patch-guile origin-patch-guile ; package or #f
(default #f))) (default #f)))
@ -272,26 +280,38 @@ corresponds to the arguments expected by `set-path-environment-variable'."
(let ((distro (resolve-interface '(gnu packages base)))) (let ((distro (resolve-interface '(gnu packages base))))
(module-ref distro 'guile-final))) (module-ref distro 'guile-final)))
(define* (patch-and-repack store source patches inputs (define* (patch-and-repack store source patches
#:key #:key
(inputs '())
(snippet #f)
(flags '("-p1")) (flags '("-p1"))
(modules '())
(imported-modules '())
(guile-for-build (%guile-for-build)) (guile-for-build (%guile-for-build))
(system (%current-system))) (system (%current-system)))
"Unpack SOURCE (a derivation), apply all of PATCHES, and repack the tarball "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
using the tools listed in INPUTS." 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 (define decompression-type
(let ((out (derivation->output-path source))) (cond ((string-suffix? "gz" source-file-name) "gzip")
(cond ((string-suffix? "gz" out) "gzip") ((string-suffix? "bz2" source-file-name) "bzip2")
((string-suffix? "bz2" out) "bzip2") ((string-suffix? "lz" source-file-name) "lzip")
((string-suffix? "lz" out) "lzip") (else "xz")))
(else "xz"))))
(define original-file-name (define original-file-name
(let ((out (derivation->output-path source))) ;; Remove the store prefix plus the slash, hash, and hyphen.
;; Remove the store prefix plus the slash, hash, and hyphen. (let* ((sans (string-drop source-file-name
(let* ((sans (string-drop out (+ (string-length (%store-prefix)) 1))) (+ (string-length (%store-prefix)) 1)))
(dash (string-index sans #\-))) (dash (string-index sans #\-)))
(string-drop sans (+ 1 dash))))) (string-drop sans (+ 1 dash))))
(define patch-inputs (define patch-inputs
(map (lambda (number patch) (map (lambda (number patch)
@ -331,7 +351,24 @@ using the tools listed in INPUTS."
(format (current-error-port) (format (current-error-port)
"source is under '~a'~%" directory) "source is under '~a'~%" directory)
(chdir directory) (chdir directory)
(and (every apply-patch ',(map car patch-inputs)) (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) (begin (chdir "..") #t)
(zero? (system* tar "cvfa" out directory)))))))) (zero? (system* tar "cvfa" out directory))))))))
@ -351,19 +388,21 @@ using the tools listed in INPUTS."
`(("source" ,source) `(("source" ,source)
,@inputs ,@inputs
,@patch-inputs) ,@patch-inputs)
#:modules imported-modules
#:guile-for-build guile-for-build))) #:guile-for-build guile-for-build)))
(define* (package-source-derivation store source (define* (package-source-derivation store source
#:optional (system (%current-system))) #:optional (system (%current-system)))
"Return the derivation path for SOURCE, a package source, for SYSTEM." "Return the derivation path for SOURCE, a package source, for SYSTEM."
(match source (match source
(($ <origin> uri method sha256 name ()) (($ <origin> uri method sha256 name () #f)
;; No patches. ;; No patches, no snippet: this is a fixed-output derivation.
(method store uri 'sha256 sha256 name (method store uri 'sha256 sha256 name
#:system system)) #:system system))
(($ <origin> uri method sha256 name (patches ...) (flags ...) (($ <origin> uri method sha256 name (patches ...) snippet
inputs guile-for-build) (flags ...) inputs (modules ...) (imported-modules ...)
;; One or more patches. guile-for-build)
;; Patches and/or a snippet.
(let ((source (method store uri 'sha256 sha256 name (let ((source (method store uri 'sha256 sha256 name
#:system system)) #:system system))
(guile (match (or guile-for-build (%guile-for-build) (guile (match (or guile-for-build (%guile-for-build)
@ -372,9 +411,13 @@ using the tools listed in INPUTS."
(package-derivation store p system)) (package-derivation store p system))
((? derivation? drv) ((? derivation? drv)
drv)))) drv))))
(patch-and-repack store source patches inputs (patch-and-repack store source patches
#:inputs inputs
#:snippet snippet
#:flags flags #:flags flags
#:system system #:system system
#:modules modules
#:imported-modules modules
#:guile-for-build guile))) #:guile-for-build guile)))
((and (? string?) (? store-path?) file) ((and (? string?) (? store-path?) file)
file) file)

347
guix/profiles.scm 100644
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 @@
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix profiles)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix records)
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
#:use-module ((guix ftp-client) #:select (ftp-open)) #:use-module ((guix ftp-client) #:select (ftp-open))
#:use-module (ice-9 ftw)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module ((gnu packages base) #:select (guile-final)) #:use-module ((gnu packages base) #:select (guile-final))
@ -51,7 +48,7 @@
;;; ;;;
;;; User profile. ;;; Profiles.
;;; ;;;
(define %user-profile-directory (define %user-profile-directory
@ -69,240 +66,6 @@
;; coexist with Nix profiles. ;; coexist with Nix profiles.
(string-append %profile-directory "/guix-profile")) (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) (define (link-to-empty-profile generation)
"Link GENERATION, a string, to the empty profile." "Link GENERATION, a string, to the empty profile."
(let* ((drv (profile-derivation (%store) (manifest '()))) (let* ((drv (profile-derivation (%store) (manifest '())))
@ -340,11 +103,6 @@ the given MANIFEST."
(else (else
(switch-to-previous-generation profile))))) ; anything 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) (define* (matching-generations str #:optional (profile %current-profile)
#:key (duration-relation <=)) #:key (duration-relation <=))
"Return the list of available generations matching a pattern in STR. See "Return the list of available generations matching a pattern in STR. See
@ -411,6 +169,50 @@ DURATION-RELATION with the current time."
filter-by-duration) filter-by-duration)
(else #f))) (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) (define (find-packages-by-description rx)
"Return the list of packages whose name, synopsis, or description matches "Return the list of packages whose name, synopsis, or description matches
RX." RX."
@ -437,16 +239,6 @@ RX."
(package-name p2)))) (package-name p2))))
same-location?)) 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) (define (input->name+path input)
"Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
(let loop ((input input)) (let loop ((input input))
@ -500,11 +292,6 @@ return its return value."
(format (current-error-port) " interrupted by signal ~a~%" SIGINT) (format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f)))) #f))))
;;;
;;; Package specifications.
;;;
(define newest-available-packages (define newest-available-packages
(memoize find-newest-available-packages)) (memoize find-newest-available-packages))
@ -536,13 +323,8 @@ version; if SPEC does not specify an output, return OUTPUT."
(package-full-name p) (package-full-name p)
sub-drv))) sub-drv)))
(let*-values (((name sub-drv) (let-values (((name version sub-drv)
(match (string-rindex spec #\:) (package-specification->name+version+output spec)))
(#f (values spec output))
(colon (values (substring spec 0 colon)
(substring spec (+ 1 colon))))))
((name version)
(package-name->name+version name)))
(match (find-best-packages-by-name name version) (match (find-best-packages-by-name name version)
((p) ((p)
(values p (ensure-output p sub-drv))) (values p (ensure-output p sub-drv)))
@ -910,6 +692,22 @@ return the new list of manifest entries."
(append to-upgrade 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. ;;; Entry point.
@ -989,44 +787,6 @@ more information.~%"))
(and (equal? name entry-name) (and (equal? name entry-name)
(equal? output entry-output))))) (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 (define current-generation-number
(generation-number profile)) (generation-number profile))
@ -1095,16 +855,10 @@ more information.~%"))
opts)) opts))
(else (else
(let* ((manifest (profile-manifest profile)) (let* ((manifest (profile-manifest profile))
(install* (options->installable opts manifest)) (install (options->installable opts manifest))
(remove (filter-map (match-lambda (remove (options->removable opts manifest))
(('remove . package)
package)
(_ #f))
opts))
(remove* (filter (cut manifest-installed? manifest <>)
remove))
(entries (entries
(append install* (append install
(fold (lambda (package result) (fold (lambda (package result)
(match package (match package
(($ <manifest-entry> name _ out _ ...) (($ <manifest-entry> name _ out _ ...)
@ -1114,7 +868,7 @@ more information.~%"))
result)))) result))))
(manifest-entries (manifest-entries
(manifest-remove manifest remove)) (manifest-remove manifest remove))
install*))) install)))
(new (make-manifest entries))) (new (make-manifest entries)))
(when (equal? profile %current-profile) (when (equal? profile %current-profile)
@ -1122,8 +876,9 @@ more information.~%"))
(if (manifest=? new manifest) (if (manifest=? new manifest)
(format (current-error-port) (_ "nothing to be done~%")) (format (current-error-port) (_ "nothing to be done~%"))
(let ((prof-drv (profile-derivation (%store) new))) (let ((prof-drv (profile-derivation (%store) new))
(show-what-to-remove/install remove* install* dry-run?) (remove (manifest-matching-entries manifest remove)))
(show-what-to-remove/install remove install dry-run?)
(show-what-to-build (%store) (list prof-drv) (show-what-to-build (%store) (list prof-drv)
#:use-substitutes? #:use-substitutes?
(assoc-ref opts 'substitutes?) (assoc-ref opts 'substitutes?)

36
guix/ui.scm
View File

@ -52,6 +52,7 @@
fill-paragraph fill-paragraph
string->recutils string->recutils
package->recutils package->recutils
package-specification->name+version+output
string->generations string->generations
string->duration string->duration
args-fold* args-fold*
@ -136,6 +137,11 @@ messages."
"Display version information for COMMAND and `(exit 0)'." "Display version information for COMMAND and `(exit 0)'."
(simple-format #t "~a (~a) ~a~%" (simple-format #t "~a (~a) ~a~%"
command %guix-package-name %guix-version) 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)) (exit 0))
(define (show-bug-report-information) (define (show-bug-report-information)
@ -358,6 +364,11 @@ converted to a space; sequences of more than one line break are preserved."
((_ _ chars) ((_ _ chars)
(list->string (reverse chars))))) (list->string (reverse chars)))))
;;;
;;; Packages.
;;;
(define (string->recutils str) (define (string->recutils str)
"Return a version of STR where newlines have been replaced by newlines "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 followed by \"+ \", which makes for a valid multi-line field value in the
@ -472,6 +483,31 @@ following patterns: \"1d\", \"1w\", \"1m\"."
(hours->duration (* 24 30) match))) (hours->duration (* 24 30) match)))
(else #f))) (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) (define (args-fold* options unrecognized-option-proc operand-proc . seeds)
"A wrapper on top of `args-fold' that does proper user-facing error "A wrapper on top of `args-fold' that does proper user-facing error
reporting." reporting."

25
tests/derivations.scm
View File

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

60
tests/packages.scm
View File

@ -20,6 +20,7 @@
(define-module (test-packages) (define-module (test-packages)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix hash)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix build-system) #:use-module (guix build-system)
@ -121,6 +122,65 @@
(package-source package)))) (package-source package))))
(string=? file source))) (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" (test-assert "return value"
(let ((drv (package-derivation %store (dummy-package "p")))) (let ((drv (package-derivation %store (dummy-package "p"))))
(and (derivation? drv) (and (derivation? drv)

97
tests/profiles.scm 100644
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 @@ interface, and powerful string processing.")
10) 10)
#\newline)) #\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" (test-equal "integer"
'(1) '(1)
(string->generations "1")) (string->generations "1"))