diff options
33 files changed, 792 insertions, 193 deletions
diff --git a/HACKING b/HACKING index 85e9a900be..ef8fb27cbe 100644 --- a/HACKING +++ b/HACKING @@ -108,6 +108,18 @@ However, it is OK for a “host-side” module to use a build-side module. Modules that deal with the broader GNU system should be in the (gnu …) name space rather than (guix …). +** Data Types and Pattern Matching + +The tendency in classical Lisp is to use lists to represent everything, and +then to browse them “by hand” using ‘car’, ‘cdr’, ‘cadr’, and co. There are +several problems with that style, notably the fact that it is hard to read, +error-prone, and a hindrance to proper type error reports. + +Guix code should define appropriate data types (for instance, using +‘define-record-type*’) rather than abuse lists. In addition, it should use +pattern matching, via Guile’s (ice-9 match) module, especially when matching +lists. + ** Formatting Code When writing Scheme code, we follow common wisdom among Scheme programmers. diff --git a/THANKS b/THANKS index 9dc330f998..c19fd2e8a7 100644 --- a/THANKS +++ b/THANKS @@ -15,6 +15,8 @@ infrastructure help: Rafael Ferreira <rafael.f.f1@gmail.com> Christian Grothoff <christian@grothoff.org> Matthew Lien <bluet@bluet.org> + Yutaka Niibe <gniibe@fsij.org> Alex Sassmannshausen <alex.sassmannshausen@gmail.com> Jason Self <jself@gnu.org> Alen Skondro <askondro@gmail.com> + Matthias Wachs <wachs@net.in.tum.de> diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm index d7bdb2d7e4..8206be22ff 100644 --- a/build-aux/hydra/gnu-system.scm +++ b/build-aux/hydra/gnu-system.scm @@ -79,7 +79,7 @@ SYSTEM." ,(cute package->alist store package system (cut package-cross-derivation <> <> target <>)))) -(define %packages-to-cross-build +(define %core-packages (list gmp mpfr mpc coreutils findutils diffutils patch sed grep gawk gettext hello guile-2.0 %bootstrap-binaries-tarball @@ -89,6 +89,9 @@ SYSTEM." %guile-bootstrap-tarball %bootstrap-tarballs)) +(define %packages-to-cross-build + %core-packages) + (define %cross-targets '("mips64el-linux-gnu" "mips64el-linux-gnuabi64")) @@ -106,6 +109,11 @@ SYSTEM." (_ (list (%current-system))))) + (define subset + (match (assoc-ref arguments 'subset) + ("core" 'core) ; only build core packages + (_ 'all))) ; build everything + (define job-name (compose string->symbol package-full-name)) @@ -127,11 +135,23 @@ SYSTEM." inputs)))) %final-inputs)))) (append-map (lambda (system) - (fold-packages (lambda (package result) - (if (member package base-packages) - result - (cons (package-job store (job-name package) - package system) - result))) - (cross-jobs system))) + (case subset + ((all) + ;; Build everything. + (fold-packages (lambda (package result) + (if (member package base-packages) + result + (cons (package-job store (job-name package) + package system) + result))) + (cross-jobs system))) + ((core) + ;; Build core packages only. + (append (map (lambda (package) + (package-job store (job-name package) + package system)) + %core-packages) + (cross-jobs system))) + (else + (error "unknown subset" subset)))) systems))) diff --git a/build-aux/hydra/guix.scm b/build-aux/hydra/guix.scm index 29a19c62e5..dbc935d897 100644 --- a/build-aux/hydra/guix.scm +++ b/build-aux/hydra/guix.scm @@ -41,7 +41,9 @@ (guix packages) (guix utils) (guix build-system gnu) + (gnu packages version-control) (gnu packages package-management) + (gnu packages graphviz) (srfi srfi-1) (srfi srfi-26) (ice-9 match)) @@ -76,7 +78,10 @@ containing a Git checkout of Guix." ;; us with a checkout that includes sub-modules. (substitute* "bootstrap" (("git ") "true git "))) - ,p))))))) + ,p)))) + (native-inputs `(("git" ,git) + ("graphviz" ,graphviz) + ,@(package-native-inputs dist)))))) (define (hydra-jobs store arguments) "Return Hydra jobs." diff --git a/doc/guix.texi b/doc/guix.texi index 5b91bc2982..5d1b780144 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1061,7 +1061,7 @@ argument. Return @code{#t} when @var{path} is a valid store path. @end deffn -@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} @var{references} +@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} [@var{references}] Add @var{text} under file @var{name} in the store, and return its store path. @var{references} is the list of store paths referred to by the resulting store path. diff --git a/gnu-system.am b/gnu-system.am index a5000bcdfe..4069301fe7 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -179,17 +179,23 @@ GNU_SYSTEM_MODULES = \ gnu/packages/yasm.scm \ gnu/packages/zile.scm \ gnu/packages/zip.scm \ + \ + gnu/system/grub.scm \ + gnu/system/linux.scm \ + gnu/system/shadow.scm \ gnu/system/vm.scm patchdir = $(guilemoduledir)/gnu/packages/patches dist_patch_DATA = \ gnu/packages/patches/apr-skip-getservbyname-test.patch \ gnu/packages/patches/automake-skip-amhello-tests.patch \ + gnu/packages/patches/avahi-localstatedir.patch \ gnu/packages/patches/bigloo-gc-shebangs.patch \ gnu/packages/patches/binutils-ld-new-dtags.patch \ gnu/packages/patches/cdparanoia-fpic.patch \ gnu/packages/patches/cmake-fix-tests.patch \ gnu/packages/patches/cpio-gets-undeclared.patch \ + gnu/packages/patches/dbus-localstatedir.patch \ gnu/packages/patches/diffutils-gets-undeclared.patch \ gnu/packages/patches/emacs-configure-sh.patch \ gnu/packages/patches/findutils-absolute-paths.patch \ @@ -202,7 +208,6 @@ dist_patch_DATA = \ gnu/packages/patches/glib-tests-prlimit.patch \ gnu/packages/patches/glibc-bootstrap-system.patch \ gnu/packages/patches/glibc-no-ld-so-cache.patch \ - gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch \ gnu/packages/patches/grub-gets-undeclared.patch \ gnu/packages/patches/guile-1.8-cpp-4.5.patch \ gnu/packages/patches/guile-default-utf8.patch \ diff --git a/gnu/packages/avahi.scm b/gnu/packages/avahi.scm index fbdc0e2834..14073b32a0 100644 --- a/gnu/packages/avahi.scm +++ b/gnu/packages/avahi.scm @@ -21,6 +21,7 @@ #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) + #:use-module (gnu packages) #:use-module (gnu packages gdbm) #:use-module (gnu packages libdaemon) #:use-module (gnu packages pkg-config) @@ -42,13 +43,15 @@ (build-system gnu-build-system) (arguments '(#:configure-flags '("--with-distro=none" + "--localstatedir=/var" ; for the DBus socket "--disable-python" "--disable-mono" "--disable-doxygen-doc" "--disable-xmltoman" "--enable-tests" "--disable-qt3" "--disable-qt4" - "--disable-gtk" "--disable-gtk3"))) + "--disable-gtk" "--disable-gtk3") + #:patches (list (assoc-ref %build-inputs "patch/localstatedir")))) (inputs `(("expat" ,expat) ("glib" ,glib) @@ -56,7 +59,10 @@ ("libdaemon" ,libdaemon) ("intltool" ,intltool) ("pkg-config" ,pkg-config) - ("gdbm" ,gdbm))) + ("gdbm" ,gdbm) + + ("patch/localstatedir" + ,(search-patch "avahi-localstatedir.patch")))) (synopsis "Avahi, an mDNS/DNS-SD implementation") (description "Avahi is a system which facilitates service discovery on a local diff --git a/gnu/packages/compression.scm b/gnu/packages/compression.scm index 9528cf3199..83ef7a86d8 100644 --- a/gnu/packages/compression.scm +++ b/gnu/packages/compression.scm @@ -189,6 +189,7 @@ than gzip and 15 % smaller output than bzip2.") (base32 "0wryshs446s7cclrbjykyj766znhcpnr7s3cxy33ybfn6vwfcygz")))) (build-system gnu-build-system) + (arguments '(#:configure-flags '("--enable-shared"))) (home-page "http://www.oberhumer.com/opensource/lzo") (synopsis "A data compresion library suitable for real-time data de-/compression") diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm index 571526ebdf..c1a2ce61c5 100644 --- a/gnu/packages/gcc.scm +++ b/gnu/packages/gcc.scm @@ -221,7 +221,7 @@ used in the GNU system including the GNU/Linux variant.") (source (origin (method url-fetch) (uri (list (string-append - "ftp://ftp.linux.student.kuleuven.be/pub/people/skimo/isl/isl-" + "http://isl.gforge.inria.fr/isl-" version ".tar.bz2") (string-append %gcc-infrastructure @@ -231,7 +231,7 @@ used in the GNU system including the GNU/Linux variant.") "13d9cqa5rzhbjq0xf0b2dyxag7pqa72xj9dhsa03m8ccr1a4npq9")))) (build-system gnu-build-system) (inputs `(("gmp" ,gmp))) - (home-page "http://www.kotnet.org/~skimo/isl/") + (home-page "http://isl.gforge.inria.fr/") (synopsis "A library for manipulating sets and relations of integer points bounded by linear constraints") diff --git a/gnu/packages/glib.scm b/gnu/packages/glib.scm index 72479f21e7..da15d404dd 100644 --- a/gnu/packages/glib.scm +++ b/gnu/packages/glib.scm @@ -50,9 +50,21 @@ (base32 "1wacqyfkcpayg7f8rvx9awqg275n5pksxq5q7y21lxjx85x6pfjz")))) (build-system gnu-build-system) + (arguments + '(#:configure-flags (list ;; Install the system bus socket under /var. + "--localstatedir=/var" + + ;; XXX: Fix the following to allow system-wide + ;; config. + ;; "--sysconfdir=/etc" + + "--with-session-socket-dir=/tmp") + #:patches (list (assoc-ref %build-inputs "patch/localstatedir")))) (inputs `(("expat" ,expat) - ("pkg-config" ,pkg-config))) + ("pkg-config" ,pkg-config) + ("patch/localstatedir" + ,(search-patch "dbus-localstatedir.patch")))) (home-page "http://dbus.freedesktop.org/") (synopsis "Message bus for inter-process communication (IPC)") (description @@ -186,6 +198,40 @@ The intltool collection can be used to do these things: oaf files. This merge step will happen at build resp. installation time.") (license license:gpl2+))) +(define-public itstool + (package + (name "itstool") + (version "1.2.0") + (source (origin + (method url-fetch) + (uri (string-append "http://files.itstool.org/itstool/itstool-" + version ".tar.bz2")) + (sha256 + (base32 + "1akq75aflihm3y7js8biy7b5mw2g11vl8yq90gydnwlwp0zxdzj6")))) + (build-system gnu-build-system) + (home-page "http://www.itstool.org") + (synopsis "Tool to translate XML documents with PO files") + (description + "ITS Tool allows you to translate your XML documents with PO files, using +rules from the W3C Internationalization Tag Set (ITS) to determine what to +translate and how to separate it into PO file messages. + +PO files are the standard translation format for GNU and other Unix-like +systems. They present translatable information as discrete messages, allowing +each message to be translated independently. In contrast to whole-page +translation, translating with a message-based format like PO means you can +easily track changes to the source document down to the paragraph. When new +strings are added or existing strings are modified, you only need to update the +corresponding messages. + +ITS Tool is designed to make XML documents translatable through PO files by +applying standard ITS rules, as well as extension rules specific to ITS Tool. +ITS also provides an industry standard way for authors to override translation +information in their documents, such as whether a particular element should be +translated.") + (license license:gpl3+))) + (define-public dbus-glib (package (name "dbus-glib") diff --git a/gnu/packages/gnutls.scm b/gnu/packages/gnutls.scm index d636a9c927..766731e289 100644 --- a/gnu/packages/gnutls.scm +++ b/gnu/packages/gnutls.scm @@ -54,7 +54,7 @@ portable, and only require an ANSI C89 platform.") (define-public gnutls (package (name "gnutls") - (version "3.2.1") + (version "3.2.4") (source (origin (method url-fetch) (uri @@ -64,20 +64,14 @@ portable, and only require an ANSI C89 platform.") version ".tar.xz")) (sha256 (base32 - "1zi2kq3vcbqdy9khl7r6pgk4hgwibniasm9k6siasdvqjijq3ymb")))) + "0zvhzy87v9dfxfvmg1pl951kw55rp647cqdza8942fxq7spp158i")))) (build-system gnu-build-system) - (arguments - `(#:patches (list (assoc-ref %build-inputs - "patch/fix-tests")) - #:patch-flags '("-p0"))) (native-inputs `(("pkg-config" ,pkg-config))) (inputs `(("guile" ,guile-2.0) ("zlib" ,guix:zlib) - ("perl" ,perl) - ("patch/fix-tests" - ,(search-patch "gnutls-fix-tests-on-32-bits-system.patch")))) + ("perl" ,perl))) (propagated-inputs `(("libtasn1" ,libtasn1) ("nettle" ,nettle) diff --git a/gnu/packages/linux-initrd.scm b/gnu/packages/linux-initrd.scm index 4a4e437635..b62843aadd 100644 --- a/gnu/packages/linux-initrd.scm +++ b/gnu/packages/linux-initrd.scm @@ -284,8 +284,9 @@ the Linux kernel.") (mkdir "/root/xchg") (mkdir-p "/root/nix/store") - (mkdir "/root/dev") - (make-essential-device-nodes #:root "/root/dev") + (unless (file-exists? "/root/dev") + (mkdir "/root/dev") + (make-essential-device-nodes #:root "/root")) ;; Mount the host's store and exchange directory. (mount-qemu-smb-share "/store" "/root/nix/store") @@ -331,4 +332,71 @@ the Linux kernel.") #:linux linux-libre #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko"))) +(define-public gnu-system-initrd + ;; Initrd for the GNU system itself, with nothing QEMU-specific. + (expression->initrd + '(begin + (use-modules (srfi srfi-1) + (srfi srfi-26) + (ice-9 match) + (guix build utils) + (guix build linux-initrd)) + + (display "Welcome, this is GNU's early boot Guile.\n") + (display "Use '--repl' for an initrd REPL.\n\n") + + (mount-essential-file-systems) + (let* ((args (linux-command-line)) + (option (lambda (opt) + (let ((opt (string-append opt "="))) + (and=> (find (cut string-prefix? opt <>) + args) + (lambda (arg) + (substring arg (+ 1 (string-index arg #\=)))))))) + (to-load (option "--load")) + (root (option "--root"))) + + (when (member "--repl" args) + ((@ (system repl repl) start-repl))) + + ;; Make /dev nodes. + (make-essential-device-nodes) + + ;; Prepare the real root file system under /root. + (unless (file-exists? "/root") + (mkdir "/root")) + (if root + ;; Assume ROOT has a usable /dev tree. + (mount root "/root" "ext3") + (begin + (mount "none" "/root" "tmpfs") + (make-essential-device-nodes #:root "/root"))) + + (mount-essential-file-systems #:root "/root") + + ;; XXX: We don't copy our fellow Guile modules to /root (see + ;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can + ;; happen if it throws, to display the exception!), then we're + ;; screwed. Hopefully TO-LOAD is a simple expression that just does + ;; '(execlp ...)'. + + (if to-load + (begin + (format #t "loading '~a'...\n" to-load) + (chroot "/root") + (primitive-load to-load) + (format (current-error-port) + "boot program '~a' terminated, rebooting~%" + to-load) + (sleep 2) + (reboot)) + (begin + (display "no init file passed via '--exec'\n") + (display "entering a warm and cozy REPL\n") + ((@ (system repl repl) start-repl)))))) + #:name "qemu-system-initrd" + #:modules '((guix build linux-initrd) + (guix build utils)) + #:linux linux-libre)) + ;;; linux-initrd.scm ends here diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index e434de477e..38bff72933 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -29,6 +29,7 @@ #:use-module (gnu packages bdb) #:use-module (gnu packages perl) #:use-module (gnu packages pkg-config) + #:use-module (gnu packages algebra) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu)) @@ -146,7 +147,7 @@ (license gpl2+))) (define-public linux-libre - (let* ((version* "3.3.8") + (let* ((version* "3.11") (build-phase '(lambda* (#:key system #:allow-other-keys #:rest args) (let ((arch (car (string-split system #\-)))) @@ -192,9 +193,10 @@ (uri (linux-libre-urls version)) (sha256 (base32 - "0jkfh0z1s6izvdnc3njm39dhzp1cg8i06jv06izwqz9w9qsprvnl")))) + "1vlk04xkvyy1kc9zz556md173rn1qzlnvhz7c9sljv4bpk3mdspl")))) (build-system gnu-build-system) (native-inputs `(("perl" ,perl) + ("bc" ,bc) ("module-init-tools" ,module-init-tools))) (arguments `(#:modules ((guix build gnu-build-system) @@ -212,6 +214,11 @@ (license gpl2) (home-page "http://www.gnu.org/software/linux-libre/")))) + +;;; +;;; Pluggable authentication modules (PAM). +;;; + (define-public linux-pam (package (name "linux-pam") @@ -253,6 +260,11 @@ be used through the PAM API to perform tasks, like authenticating a user at login. Local and dynamic reconfiguration are its key features") (license bsd-3))) + +;;; +;;; Miscellaneous. +;;; + (define-public psmisc (package (name "psmisc") diff --git a/gnu/packages/patches/avahi-localstatedir.patch b/gnu/packages/patches/avahi-localstatedir.patch new file mode 100644 index 0000000000..76377d1057 --- /dev/null +++ b/gnu/packages/patches/avahi-localstatedir.patch @@ -0,0 +1,12 @@ +Don't "mkdir $(localstatedir)" since we can't do it (/var). + +--- avahi-0.6.27/avahi-daemon/Makefile.in 2010-07-13 05:06:35.000000000 +0200 ++++ avahi-0.6.27/avahi-daemon/Makefile.in 2010-07-13 18:03:45.000000000 +0200 +@@ -1554,7 +1554,6 @@ xmllint: + done + + install-data-local: +- test -z "$(localstatedir)/run" || $(mkdir_p) "$(DESTDIR)$(localstatedir)/run" + + update-systemd: + curl http://cgit.freedesktop.org/systemd/plain/src/sd-daemon.c > sd-daemon.c diff --git a/gnu/packages/patches/dbus-localstatedir.patch b/gnu/packages/patches/dbus-localstatedir.patch new file mode 100644 index 0000000000..61bed91b5c --- /dev/null +++ b/gnu/packages/patches/dbus-localstatedir.patch @@ -0,0 +1,30 @@ +Do not try to create $localstatedir and $sysconfdir since we cannot do this +when they are /var and /etc. + +--- dbus-1.6.4/bus/Makefile.in 2013-09-11 16:15:13.000000000 +0200 ++++ dbus-1.6.4/bus/Makefile.in 2013-09-11 16:15:15.000000000 +0200 +@@ -1510,9 +1510,6 @@ clean-local: + /bin/rm *.bb *.bbg *.da *.gcov || true + + install-data-hook: +- $(mkinstalldirs) $(DESTDIR)$(localstatedir)/run/dbus +- $(mkinstalldirs) $(DESTDIR)$(configdir)/system.d +- $(mkinstalldirs) $(DESTDIR)$(configdir)/session.d + $(mkinstalldirs) $(DESTDIR)$(datadir)/dbus-1/services + $(mkinstalldirs) $(DESTDIR)$(datadir)/dbus-1/system-services + # Install dbus.socket as default implementation of a D-Bus stack. + +--- dbus-1.6.4/tools/Makefile.in 2013-09-11 16:10:31.000000000 +0200 ++++ dbus-1.6.4/tools/Makefile.in 2013-09-11 16:10:32.000000000 +0200 +@@ -757,11 +757,6 @@ uninstall-am: uninstall-binPROGRAMS + + + # create the /var/lib/dbus directory for dbus-uuidgen +-install-data-local: +- $(MKDIR_P) $(DESTDIR)$(localstatedir)/lib/dbus +- +-installcheck-local: +- test -d $(DESTDIR)$(localstatedir)/lib/dbus + + # Tell versions [3.59,3.63) of GNU make to not export all variables. + # Otherwise a system limit (for SysV at least) may be exceeded. diff --git a/gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch b/gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch deleted file mode 100644 index 07d633149e..0000000000 --- a/gnu/packages/patches/gnutls-fix-tests-on-32-bits-system.patch +++ /dev/null @@ -1,36 +0,0 @@ -From b12040aeab5fbaf02677571db1d8bf1995bd5ee0 Mon Sep 17 00:00:00 2001 -From: Nikos Mavrogiannopoulos <nmav@gnutls.org> -Date: Sun, 2 Jun 2013 12:10:06 +0200 -Subject: [PATCH] Avoid comparing the expiration date to prevent false positive -error in 32-bit systems. - ---- - tests/cert-tests/pem-decoding | 6 ++++-- - 1 files changed, 4 insertions(+), 2 deletions(-) - -diff --git a/tests/cert-tests/pem-decoding b/tests/cert-tests/pem-decoding -index fe769ec..f8c6372 100755 ---- tests/cert-tests/pem-decoding -+++ tests/cert-tests/pem-decoding -@@ -61,7 +61,9 @@ if test "$rc" != "0"; then - exit $rc - fi - --diff $srcdir/complex-cert.pem tmp-pem.pem -+cat $srcdir/complex-cert.pem |grep -v "Not After:" >tmp1 -+cat $srcdir/tmp-pem.pem |grep -v "Not After:" >tmp2 -+diff tmp1 tmp2 - rc=$? - - if test "$rc" != "0"; then -@@ -69,6 +71,6 @@ if test "$rc" != "0"; then - exit $rc - fi - --rm -f tmp-pem.pem -+rm -f tmp-pem.pem tmp1 tmp2 - - exit 0 --- -1.7.1 - diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm index b7ce8ad8aa..9a0e3e274b 100644 --- a/gnu/packages/xorg.scm +++ b/gnu/packages/xorg.scm @@ -100,7 +100,7 @@ rasterisation.") (define-public libdrm (package (name "libdrm") - (version "2.4.42") + (version "2.4.46") (source (origin (method url-fetch) @@ -110,7 +110,7 @@ rasterisation.") ".tar.bz2")) (sha256 (base32 - "1qbnpi64hyqzd650hj6jki1d50pzypdhj3rw9m3whwbqly110rz0")))) + "1wah4qmrrcv0gnx65lhrlxb6gprxch92wy8lhxv6102fml6k5krk")))) (build-system gnu-build-system) (inputs `(("libpciaccess" ,libpciaccess) @@ -4139,9 +4139,9 @@ tracking.") (define-public mesa (package (name "mesa") - ;; In newer versions (9.0.5 and 9.1 tested), "make" results in an + ;; In newer versions (9.0.5, 9.1 and 9.2 tested), "make" results in an ;; infinite configure loop, see - ;; https://bugs.freedesktop.org/show_bug.cgi?id=61527 + ;; https://bugs.freedesktop.org/show_bug.cgi?id=58812 (version "8.0.5") (source (origin diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm new file mode 100644 index 0000000000..695a044bfa --- /dev/null +++ b/gnu/system/grub.scm @@ -0,0 +1,84 @@ +;;; 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 (gnu system grub) + #:use-module (guix store) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix records) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (menu-entry + menu-entry? + grub-configuration-file)) + +;;; Commentary: +;;; +;;; Configuration of GNU GRUB. +;;; +;;; Code: + +(define-record-type* <menu-entry> + menu-entry make-menu-entry + menu-entry? + (label menu-entry-label) + (linux menu-entry-linux) + (linux-arguments menu-entry-linux-arguments + (default '())) + (initrd menu-entry-initrd)) + +(define* (grub-configuration-file store entries + #:key (default-entry 1) (timeout 5) + (system (%current-system))) + "Return the GRUB configuration file in STORE for ENTRIES, a list of +<menu-entry> objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT." + (define prologue + (format #f " +set default=~a +set timeout=~a +search.file ~a~%" + default-entry timeout + (any (match-lambda + (($ <menu-entry> _ linux) + (let* ((drv (package-derivation store linux system)) + (out (derivation-path->output-path drv))) + (string-append out "/bzImage")))) + entries))) + + (define entry->text + (match-lambda + (($ <menu-entry> label linux arguments initrd) + (let ((linux-drv (package-derivation store linux system)) + (initrd-drv (package-derivation store initrd system))) + ;; XXX: Assume that INITRD is a directory containing an 'initrd' file. + (format #f "menuentry ~s { + linux ~a/bzImage ~a + initrd ~a/initrd +}~%" + label + (derivation-path->output-path linux-drv) + (string-join arguments) + (derivation-path->output-path initrd-drv)))))) + + (add-text-to-store store "grub.cfg" + (string-append prologue + (string-concatenate + (map entry->text entries))) + '())) + +;;; grub.scm ends here diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm new file mode 100644 index 0000000000..b2daa13e06 --- /dev/null +++ b/gnu/system/linux.scm @@ -0,0 +1,145 @@ +;;; 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 (gnu system linux) + #:use-module (guix store) + #:use-module (guix records) + #:use-module (guix derivations) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module ((guix utils) #:select (%current-system)) + #:export (pam-service + pam-entry + pam-services->directory + %pam-other-services + unix-pam-service)) + +;;; Commentary: +;;; +;;; Configuration of Linux-related things, including pluggable authentication +;;; modules (PAM). +;;; +;;; Code: + +;; PAM services (see +;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-file.html>.) +(define-record-type* <pam-service> pam-service + make-pam-service + pam-service? + (name pam-service-name) ; string + + ;; The four "management groups". + (account pam-service-account ; list of <pam-entry> + (default '())) + (auth pam-service-auth + (default '())) + (password pam-service-password + (default '())) + (session pam-service-session + (default '()))) + +(define-record-type* <pam-entry> pam-entry + make-pam-entry + pam-entry? + (control pam-entry-control) ; string + (module pam-entry-module) ; file name + (arguments pam-entry-arguments ; list of strings + (default '()))) + +(define (pam-service->configuration service) + "Return the configuration string for SERVICE, to be dumped in +/etc/pam.d/NAME, where NAME is the name of SERVICE." + (define (entry->string type entry) + (match entry + (($ <pam-entry> control module (arguments ...)) + (string-append type " " + control " " module " " + (string-join arguments) + "\n")))) + + (match service + (($ <pam-service> name account auth password session) + (string-concatenate + (append (map (cut entry->string "account" <>) account) + (map (cut entry->string "auth" <>) auth) + (map (cut entry->string "password" <>) password) + (map (cut entry->string "session" <>) session)))))) + +(define (pam-services->directory store services) + "Return the derivation to build the configuration directory to be used as +/etc/pam.d for SERVICES." + (let ((names (map pam-service-name services)) + (files (map (match-lambda + ((and service ($ <pam-service> name)) + (let ((config (pam-service->configuration service))) + (add-text-to-store store + (string-append name ".pam") + config '())))) + services))) + (define builder + '(begin + (use-modules (ice-9 match)) + + (let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (for-each (match-lambda + ((name . file) + (symlink file (string-append out "/" name)))) + %build-inputs) + #t))) + + (build-expression->derivation store "pam.d" (%current-system) + builder + (zip names files)))) + +(define %pam-other-services + ;; The "other" PAM configuration, which denies everything (see + ;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.) + (let ((deny (pam-entry + (control "required") + (module "pam_deny.so")))) + (pam-service + (name "other") + (account (list deny)) + (auth (list deny)) + (password (list deny)) + (session (list deny))))) + +(define unix-pam-service + (let ((unix (pam-entry + (control "required") + (module "pam_unix.so")))) + (lambda* (name #:key allow-empty-passwords?) + "Return a standard Unix-style PAM service for NAME. When +ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords." + ;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>. + (let ((name* name)) + (pam-service + (name name*) + (account (list unix)) + (auth (list (if allow-empty-passwords? + (pam-entry + (control "required") + (module "pam_unix.so") + (arguments '("nullok"))) + unix))) + (password (list unix)) + (session (list unix))))))) + +;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm new file mode 100644 index 0000000000..71f8e0d771 --- /dev/null +++ b/gnu/system/shadow.scm @@ -0,0 +1,57 @@ +;;; 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 (gnu system shadow) + #:use-module (guix store) + #:use-module (ice-9 match) + #:export (passwd-file)) + +;;; Commentary: +;;; +;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.) +;;; +;;; Code: + +(define* (passwd-file store accounts #:key shadow?) + "Return a password file for ACCOUNTS, a list of vectors as returned by +'getpwnam'. If SHADOW? is true, then it is a /etc/shadow file, otherwise it +is a /etc/passwd file." + ;; XXX: The resulting file is world-readable, so beware when SHADOW? is #t! + (define contents + (let loop ((accounts accounts) + (result '())) + (match accounts + ((#(name pass uid gid comment home-dir shell) rest ...) + (loop rest + (cons (if shadow? + (string-append name + ":" ; XXX: use (crypt PASS …)? + ":::::::") + (string-append name + ":" "x" + ":" (number->string uid) + ":" (number->string gid) + ":" comment ":" home-dir ":" shell)) + result))) + (() + (string-join (reverse result) "\n" 'suffix))))) + + (add-text-to-store store (if shadow? "shadow" "passwd") + contents '())) + +;;; shadow.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 3bc94f4575..192ed1d5a3 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -21,7 +21,11 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) - #:use-module ((gnu packages base) #:select (%final-inputs guile-final)) + #:use-module ((gnu packages base) #:select (%final-inputs + guile-final + coreutils)) + #:use-module (gnu packages guile) + #:use-module (gnu packages bash) #:use-module (gnu packages qemu) #:use-module (gnu packages parted) #:use-module (gnu packages grub) @@ -29,13 +33,19 @@ #:use-module (gnu packages linux-initrd) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) - #:use-module ((gnu packages system) - #:select (shadow)) + #:use-module (gnu packages system) + + #:use-module (gnu system shadow) + #:use-module (gnu system linux) + #:use-module (gnu system grub) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:export (expression->derivation-in-linux-vm - qemu-image)) + qemu-image + system-qemu-image)) ;;; Commentary: @@ -71,6 +81,9 @@ DISK-IMAGE-SIZE bytes and return it. When REFERENCES-GRAPHS is true, it must be a list of file name/store path pairs, as for `derivation'. The files containing the reference graphs are made available under the /xchg CIFS share." + ;; FIXME: Allow use of macros from other modules, as done in + ;; `build-expression->derivation'. + (define input-alist (map (match-lambda ((input (? package? package)) @@ -176,19 +189,20 @@ made available under the /xchg CIFS share." (name "qemu-image") (system (%current-system)) (disk-image-size (* 100 (expt 2 20))) - (linux linux-libre) - (initrd qemu-initrd) + grub-configuration + (populate #f) (inputs '()) - (inputs-to-copy '()) - (boot-expression #f)) - "Return a bootable, stand-alone QEMU image. + (inputs-to-copy '())) + "Return a bootable, stand-alone QEMU image. The returned image is a full +disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its +configuration file. INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied into the image being built. -When BOOT-EXPRESSION is true, it is an expression to evaluate when the basic -initialization is done. A typical example is `(execl ...)' to launch the init -process." +When POPULATE is true, it must be the store file name of a Guile script to run +in the disk image partition once it has been populated with INPUTS-TO-COPY. +It can be used to provide additional files, such as /etc files." (define input->name+derivation (match-lambda ((name (? package? package)) @@ -197,20 +211,17 @@ process." ((name (? package? package) sub-drv) `(,name . ,(derivation-path->output-path (package-derivation store package system) - sub-drv))))) - - (define loader - (and boot-expression - (add-text-to-store store "loader" - (object->string boot-expression) - '()))) + sub-drv))) + ((input (and (? string?) (? store-path?) file)) + `(,input . ,file)))) (expression->derivation-in-linux-vm store "qemu-image" `(let () (use-modules (ice-9 rdelim) (srfi srfi-1) - (guix build utils)) + (guix build utils) + (guix build linux-initrd)) (let ((parted (string-append (assoc-ref %build-inputs "parted") "/sbin/parted")) @@ -220,12 +231,7 @@ process." "/sbin/grub-install")) (umount (string-append (assoc-ref %build-inputs "util-linux") "/bin/umount")) ; XXX: add to Guile - (initrd (string-append (assoc-ref %build-inputs "initrd") - "/initrd")) - (linux (string-append (assoc-ref %build-inputs "linux") - "/bzImage")) - (makedev (lambda (major minor) - (+ (* major 256) minor)))) + (grub.cfg (assoc-ref %build-inputs "grub.cfg"))) (define (read-reference-graph port) ;; Return a list of store paths from the reference graph at PORT. @@ -265,7 +271,6 @@ process." (assoc-ref %build-inputs "gawk") "/bin")) (display "creating partition table...\n") - (mknod "/dev/vda" 'block-special #o644 (makedev 8 0)) (and (zero? (system* parted "/dev/vda" "mklabel" "msdos" "mkpart" "primary" "ext2" "1MiB" ,(format #f "~aB" @@ -273,15 +278,13 @@ process." (* 5 (expt 2 20)))))) (begin (display "creating ext3 partition...\n") - (mknod "/dev/vda1" 'block-special #o644 (makedev 8 1)) (and (zero? (system* mkfs "-F" "/dev/vda1")) (begin (display "mounting partition...\n") (mkdir "/fs") (mount "/dev/vda1" "/fs" "ext3") (mkdir-p "/fs/boot/grub") - (copy-file linux "/fs/boot/bzImage") - (copy-file initrd "/fs/boot/initrd") + (symlink grub.cfg "/fs/boot/grub/grub.cfg") ;; Populate the image's store. (mkdir-p (string-append "/fs" ,%store-directory)) @@ -289,39 +292,41 @@ process." (copy-recursively thing (string-append "/fs" thing))) - (things-to-copy)) - - (call-with-output-file "/fs/boot/grub/grub.cfg" - (lambda (p) - (format p " -set default=1 -set timeout=5 -search.file /boot/bzImage - -menuentry \"Boot-to-Guile! (GNU System technology preview)\" { - linux /boot/bzImage --root=/dev/vda1 ~a - initrd /boot/initrd -}" - ,(if loader - (string-append "--load=" loader) - "")))) + (cons grub.cfg (things-to-copy))) + + ;; Populate /dev. + (make-essential-device-nodes #:root "/fs") + + (and=> (assoc-ref %build-inputs "populate") + (lambda (populate) + (chdir "/fs") + (primitive-load populate) + (chdir "/"))) + + (display "clearing file timestamps...\n") + (for-each (lambda (file) + (let ((s (lstat file))) + ;; XXX: Guile uses libc's 'utime' function + ;; (not 'futime'), so the timestamp of + ;; symlinks cannot be changed, and there + ;; are symlinks here pointing to + ;; /nix/store, which is the host, + ;; read-only store. + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files "/fs" ".*")) + (and (zero? (system* grub "--no-floppy" "--boot-directory" "/fs/boot" "/dev/vda")) - (zero? - (system* umount "/fs")) + (zero? (system* umount "/fs")) (reboot)))))))) #:system system #:inputs `(("parted" ,parted) ("grub" ,grub) ("e2fsprogs" ,e2fsprogs) - ("linux" ,linux-libre) - ("initrd" ,initrd) - - ,@(if loader - `(("loader" ,loader)) - '()) + ("grub.cfg" ,grub-configuration) ;; For shell scripts. ("sed" ,(car (assoc-ref %final-inputs "sed"))) @@ -331,49 +336,99 @@ menuentry \"Boot-to-Guile! (GNU System technology preview)\" { ("gawk" ,(car (assoc-ref %final-inputs "gawk"))) ("util-linux" ,util-linux) + ,@(if populate + `(("populate" ,populate)) + '()) + ,@inputs-to-copy) #:make-disk-image? #t #:disk-image-size disk-image-size #:references-graphs (map input->name+derivation inputs-to-copy) - #:modules '((guix build utils)))) + #:modules '((guix build utils) + (guix build linux-initrd)))) ;;; -;;; Guile 2.0 potluck examples. +;;; Stand-alone VM image. ;;; -(define (example1) - (let ((store #f)) - (dynamic-wind - (lambda () - (set! store (open-connection))) - (lambda () - (parameterize ((%guile-for-build (package-derivation store guile-final))) - (expression->derivation-in-linux-vm - store "vm-test" - '(begin - (display "hello from boot!\n") - (call-with-output-file "/xchg/hello" - (lambda (p) - (display "world" p))))))) - (lambda () - (close-connection store))))) - -(define (example2) - (let ((store #f)) - (dynamic-wind - (lambda () - (set! store (open-connection))) - (lambda () - (parameterize ((%guile-for-build (package-derivation store guile-final))) - (let* ((drv (package-derivation store shadow)) - (login (string-append (derivation-path->output-path drv) - "/bin/login"))) - (qemu-image store - #:boot-expression `(execl ,login "login" "tty1") - #:disk-image-size (* 400 (expt 2 20)) - #:inputs-to-copy `(("shadow" ,shadow)))))) - (lambda () - (close-connection store))))) +(define (system-qemu-image store) + "Return the derivation of a QEMU image of the GNU system." + (define %pam-services + ;; Services known to PAM. + (list %pam-other-services + (unix-pam-service "login" #:allow-empty-passwords? #t))) + + (parameterize ((%guile-for-build (package-derivation store guile-final))) + (let* ((bash-drv (package-derivation store bash)) + (bash-file (string-append (derivation-path->output-path bash-drv) + "/bin/bash")) + (accounts (list (vector "root" "" 0 0 "System administrator" + "/" bash-file))) + (passwd (passwd-file store accounts)) + (shadow (passwd-file store accounts #:shadow? #t)) + (pam.d-drv (pam-services->directory store %pam-services)) + (pam.d (derivation-path->output-path pam.d-drv)) + (populate + (add-text-to-store store "populate-qemu-image" + (object->string + `(begin + (mkdir-p "etc") + (symlink ,shadow "etc/shadow") + (symlink ,passwd "etc/passwd") + (symlink "/dev/null" + "etc/login.defs") + (symlink ,pam.d "etc/pam.d") + (mkdir-p "var/run"))) + (list passwd))) + (out (derivation-path->output-path + (package-derivation store mingetty))) + (getty (string-append out "/sbin/mingetty")) + (iu-drv (package-derivation store inetutils)) + (syslogd (string-append (derivation-path->output-path iu-drv) + "/libexec/syslogd")) + (boot (add-text-to-store store "boot" + (object->string + `(begin + ;; Become the session leader, + ;; so that mingetty can do + ;; 'TIOCSCTTY'. + (setsid) + + (when (zero? (primitive-fork)) + (format #t "starting syslogd as ~a~%" + (getpid)) + (execl ,syslogd "syslogd")) + + ;; Directly into mingetty. XXX + ;; (execl ,getty "mingetty" + ;; "--noclear" "tty1") + (execl ,bash-file "bash"))) + (list out))) + (entries (list (menu-entry + (label "Boot-to-Guile! (GNU System technology preview)") + (linux linux-libre) + (linux-arguments `("--root=/dev/vda1" + ,(string-append "--load=" boot))) + (initrd gnu-system-initrd)))) + (grub.cfg (grub-configuration-file store entries))) + (build-derivations store (list pam.d-drv)) + (qemu-image store + #:grub-configuration grub.cfg + #:populate populate + #:disk-image-size (* 400 (expt 2 20)) + #:inputs-to-copy `(("boot" ,boot) + ("linux" ,linux-libre) + ("initrd" ,gnu-system-initrd) + ("coreutils" ,coreutils) + ("bash" ,bash) + ("guile" ,guile-2.0) + ("mingetty" ,mingetty) + ("inetutils" ,inetutils) + + ;; Configuration. + ("etc-pam.d" ,pam.d) + ("etc-passwd" ,passwd) + ("etc-shadow" ,shadow)))))) ;;; vm.scm ends here diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 3347dc502c..76a9a3befe 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -35,13 +35,20 @@ ;; ;; Code: +(define (default-cmake) + "Return the default CMake package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages cmake)))) + (module-ref module 'cmake))) + (define* (cmake-build store name source inputs #:key (guile #f) (outputs '("out")) (configure-flags ''()) (search-paths '()) (make-flags ''()) (patches ''()) (patch-flags ''("--batch" "-p1")) - (cmake (@ (gnu packages cmake) cmake)) + (cmake (default-cmake)) (out-of-source? #f) (tests? #t) (test-target "test") diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 208ad711ef..cbdb363b4e 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -80,13 +80,19 @@ (mknod (scope "dev/vda2") 'block-special #o644 (device-number 8 2)) ;; TTYs. + (mknod (scope "dev/tty") 'char-special #o600 + (device-number 5 0)) (let loop ((n 0)) (and (< n 50) (let ((name (format #f "dev/tty~a" n))) - (mknod (scope name) 'block-special #o644 + (mknod (scope name) 'char-special #o600 (device-number 4 n)) (loop (+ 1 n))))) + ;; Rendez-vous point for syslogd. + (mknod (scope "dev/log") 'socket #o666 0) + (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11)) + ;; Other useful nodes. (mknod (scope "dev/null") 'char-special #o666 (device-number 1 3)) (mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5))) diff --git a/guix/build/union.scm b/guix/build/union.scm index 275746d83e..077b7fe530 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -105,7 +105,22 @@ single leaf." the DIRECTORIES." (define (file-tree dir) ;; Return the contents of DIR as a tree. - (match (file-system-fold (const #t) + + (define (others-have-it? subdir) + ;; Return #t if other elements of DIRECTORIES have SUBDIR. + (let ((subdir (substring subdir (string-length dir)))) + (any (lambda (other) + (and (not (string=? other dir)) + (file-exists? (string-append other "/" subdir)))) + directories))) + + (match (file-system-fold (lambda (subdir stat result) ; enter? + ;; No need to traverse DIR since there's + ;; nothing to union it with. Thus, we avoid + ;; creating a gazillon symlinks (think + ;; share/emacs/24.3, share/texmf, etc.) + (or (string=? subdir dir) + (others-have-it? subdir))) (lambda (file stat result) ; leaf (match result (((siblings ...) rest ...) @@ -117,7 +132,12 @@ the DIRECTORIES." (((leaves ...) (siblings ...) rest ...) `(((,(basename dir) ,@leaves) ,@siblings) ,@rest)))) - (const #f) ; skip + (lambda (dir stat result) ; skip + ;; DIR is not available elsewhere, so treat it + ;; as a leaf. + (match result + (((siblings ...) rest ...) + `((,dir ,@siblings) ,@rest)))) (lambda (file stat errno result) (format (current-error-port) "union-build: ~a: ~a~%" file (strerror errno))) @@ -158,8 +178,9 @@ the DIRECTORIES." (mkdir output) (let loop ((tree (delete-duplicate-leaves (cons "." - (tree-union (append-map (compose tree-leaves file-tree) - directories))) + (tree-union + (append-map (compose tree-leaves file-tree) + (delete-duplicates directories)))) leaf=? resolve-collision)) (dir '())) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5c3947dd63..1393ca3180 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -95,7 +95,7 @@ (make-regexp (string-append "^" (regexp-quote (basename profile)) "-([0-9]+)"))) -(define (profile-numbers profile) +(define (generation-numbers profile) "Return the list of generation numbers of PROFILE, or '(0) if no former profiles were found." (define* (scandir name #:optional (select? (const #t)) @@ -144,7 +144,7 @@ former profiles were found." (cute regexp-exec (profile-regexp profile) <>)) profiles)))) -(define (previous-profile-number profile number) +(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\")." @@ -153,7 +153,7 @@ case when generations have been deleted (there are \"holes\")." candidate highest)) 0 - (profile-numbers profile))) + (generation-numbers profile))) (define (profile-derivation store packages) "Return a derivation that builds a profile (a user environment) with @@ -205,7 +205,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." packages) #:modules '((guix build union)))) -(define (profile-number profile) +(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)))) @@ -214,17 +214,17 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (define (roll-back profile) "Roll back to the previous generation of PROFILE." - (let* ((number (profile-number profile)) - (previous-number (previous-profile-number profile number)) - (previous-profile (format #f "~a-~a-link" - profile previous-number)) - (manifest (string-append previous-profile "/manifest"))) + (let* ((number (generation-number profile)) + (previous-number (previous-generation-number profile number)) + (previous-generation (format #f "~a-~a-link" + profile previous-number)) + (manifest (string-append previous-generation "/manifest"))) (define (switch-link) - ;; Atomically switch PROFILE to the previous profile. + ;; Atomically switch PROFILE to the previous generation. (format #t (_ "switching from generation ~a to ~a~%") number previous-number) - (switch-symlinks profile previous-profile)) + (switch-symlinks profile previous-generation)) (cond ((not (file-exists? profile)) ; invalid profile (leave (_ "profile `~a' does not exist~%") @@ -233,7 +233,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (format (current-error-port) (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness - (not (file-exists? previous-profile))) + (not (file-exists? previous-generation))) (let*-values (((drv-path drv) (profile-derivation (%store) '())) ((prof) @@ -242,7 +242,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (when (not (build-derivations (%store) (list drv-path))) (leave (_ "failed to build the empty profile~%"))) - (switch-symlinks previous-profile prof) + (switch-symlinks previous-generation prof) (switch-link))) (else (switch-link))))) ; anything else @@ -846,7 +846,7 @@ more information.~%")) (%store) (manifest-packages (profile-manifest profile)))) (old-prof (derivation-path->output-path old-drv)) - (number (profile-number profile)) + (number (generation-number profile)) ;; Always use NUMBER + 1 for the new profile, ;; possibly overwriting a "previous future diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index f4135efc99..f3d87a63c0 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -106,6 +106,8 @@ files." (when (string-suffix? ".scm" file) (let ((go (string-append (string-drop-right file 4) ".go"))) + (format (current-error-port) + "compiling '~a'...~%" file) (compile-file file #:output-file go #:opts %auto-compilation-options)))) @@ -114,7 +116,9 @@ files." ;; download), we must build it first to avoid errors since ;; (gnutls) is unavailable. (cons (string-append out "/guix/build/download.scm") - (find-files out "\\.scm"))) + + ;; Sort the file names to get deterministic results. + (sort (find-files out "\\.scm") string<?))) ;; Remove the "fake" (guix config). (delete-file (string-append out "/guix/config.scm")) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 97bbfcbce8..1afc93bbc9 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -446,6 +446,30 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;;; +;;; Help. +;;; + +(define (show-help) + (display (_ "Usage: guix substitute-binary [OPTION]... +Internal tool to substitute a pre-built binary to a local build.\n")) + (display (_ " + --query report on the availability of substitutes for the + store file names passed on the standard input")) + (display (_ " + --substitute STORE-FILE DESTINATION + download STORE-FILE and store it as a Nar in file + DESTINATION")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + + +;;; ;;; Entry point. ;;; @@ -508,8 +532,13 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) - (format (current-error-port) "downloading `~a' from `~a'...~%" - store-path (uri->string uri)) + (format (current-error-port) "downloading `~a' from `~a'~:[~*~; (~,1f MiB installed)~]...~%" + store-path (uri->string uri) + + ;; Use the Nar size as an estimate of the installed size. + (narinfo-size narinfo) + (and=> (narinfo-size narinfo) + (cute / <> (expt 2. 20)))) (let*-values (((raw download-size) ;; Note that Hydra currently generates Nars on the fly ;; and doesn't specify a Content-Length, so @@ -531,7 +560,11 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by (restore-file input destination) (every (compose zero? cdr waitpid) pids)))) (("--version") - (show-version-and-exit "guix substitute-binary"))))) + (show-version-and-exit "guix substitute-binary")) + (("--help") + (show-help)) + (opts + (leave (_ "~a: unrecognized options~%") opts))))) ;;; Local Variables: diff --git a/guix/store.scm b/guix/store.scm index 541c7c848f..0f1e2f9466 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -452,7 +452,7 @@ encoding conversion errors." (string-list references)) #f store-path))) - (lambda (server name text references) + (lambda* (server name text #:optional (references '())) "Add TEXT under file NAME in the store, and return its store path. REFERENCES is the list of store paths referred to by the resulting store path." diff --git a/guix/ui.scm b/guix/ui.scm index 9251d73f18..720d01be02 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -242,6 +242,7 @@ available for download." (substitutable-path-info store download))))) download))) + ;; TODO: Show the installed size of DOWNLOAD. (if dry-run? (begin (format (current-error-port) diff --git a/nix/libutil/gcrypt-hash.cc b/nix/libutil/gcrypt-hash.cc index b364a5747a..553f633b93 100644 --- a/nix/libutil/gcrypt-hash.cc +++ b/nix/libutil/gcrypt-hash.cc @@ -1,5 +1,5 @@ /* GNU Guix --- Functional package management for GNU - Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> + Copyright (C) 2012, 2013 Ludovic Courtès <ludo@gnu.org> This file is part of GNU Guix. @@ -24,7 +24,7 @@ extern "C" { void -guix_hash_init (struct guix_hash_context *ctx, gcry_md_algo_t algo) +guix_hash_init (struct guix_hash_context *ctx, int algo) { gcry_error_t err; @@ -40,7 +40,7 @@ guix_hash_update (struct guix_hash_context *ctx, const void *buffer, size_t len) void guix_hash_final (void *resbuf, struct guix_hash_context *ctx, - gcry_md_algo_t algo) + int algo) { memcpy (resbuf, gcry_md_read (ctx->md_handle, algo), gcry_md_get_algo_dlen (algo)); diff --git a/nix/libutil/gcrypt-hash.hh b/nix/libutil/gcrypt-hash.hh index d2d40d5fb2..d93a6eb881 100644 --- a/nix/libutil/gcrypt-hash.hh +++ b/nix/libutil/gcrypt-hash.hh @@ -1,5 +1,5 @@ /* GNU Guix --- Functional package management for GNU - Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> + Copyright (C) 2012, 2013 Ludovic Courtès <ludo@gnu.org> This file is part of GNU Guix. @@ -30,10 +30,10 @@ struct guix_hash_context gcry_md_hd_t md_handle; }; -extern void guix_hash_init (struct guix_hash_context *ctx, gcry_md_algo_t algo); +extern void guix_hash_init (struct guix_hash_context *ctx, int algo); extern void guix_hash_update (struct guix_hash_context *ctx, const void *buffer, size_t len); extern void guix_hash_final (void *resbuf, struct guix_hash_context *ctx, - gcry_md_algo_t algo); + int algo); } diff --git a/tests/store.scm b/tests/store.scm index 9625a6b308..0280713191 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -68,8 +68,7 @@ (test-skip (if %store 0 10)) (test-assert "dead-paths" - (let ((p (add-text-to-store %store "random-text" - (random-text) '()))) + (let ((p (add-text-to-store %store "random-text" (random-text)))) (member p (dead-paths %store)))) ;; FIXME: Find a test for `live-paths'. @@ -99,7 +98,7 @@ (test-assert "references" (let* ((t1 (add-text-to-store %store "random1" - (random-text) '())) + (random-text))) (t2 (add-text-to-store %store "random2" (random-text) (list t1)))) (and (equal? (list t1) (references %store t2)) diff --git a/tests/union.scm b/tests/union.scm index 9816882101..6287cffc38 100644 --- a/tests/union.scm +++ b/tests/union.scm @@ -114,7 +114,17 @@ (file-exists? "bin/ld") (file-exists? "lib/libc.so") (directory-exists? "lib/gcc") - (file-exists? "include/unistd.h")))))) + (file-exists? "include/unistd.h") + + ;; The 'include' sub-directory is only found in + ;; glibc-bootstrap, so it should be unified in a + ;; straightforward way, without traversing it. + (eq? 'symlink (stat:type (lstat "include"))) + + ;; Conversely, several inputs have a 'bin' sub-directory, so + ;; unifying it requires traversing them all, and creating a + ;; new 'bin' sub-directory in the profile. + (eq? 'directory (stat:type (lstat "bin")))))))) (test-end) |