diff options
43 files changed, 1123 insertions, 270 deletions
@@ -3,26 +3,12 @@ #+TITLE: What's left to do? #+STARTUP: content hidestars -Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. -* integrate needed Nix code - -** MAYBE Add a substituter that uses the GNUnet DHT or [[http://libswift.org][libswift]] - -Would be neat if binaries could be pushed to and pulled from the GNUnet DHT or -rather libswift (since DHTs aren’t suited for large payloads). Guix users -would sign their binaries, and define which binaries they trust. - -Use UPnP and similar to traverse NAT, like ‘filegive’ does. - -** Add a remote build hook - -Like scripts/build-remote.pl in Nix. - * Add `guix publish' to publish the store using Guile's web server Generate narinfos and nars on the fly, upon HTTP GET requests. @@ -30,16 +16,18 @@ Ideally, extend .nix-cache-info to include the server's public key, and also reply to requests for .narinfo.sig. Optionally, use Guile-Avahi to publish the service. -* user interface -** Add a package.el (Emacs) back-end +* MAYBE Add a substituter that uses the GNUnet DHT or [[http://libswift.org][libswift]] -package.el is quite monolithic, but we may be able to reuse/extend -‘package-menu-mode’ or at least ‘tabulated-list-mode’. +Would be neat if binaries could be pushed to and pulled from the GNUnet DHT or +rather libswift (since DHTs aren’t suited for large payloads). Guix users +would sign their binaries, and define which binaries they trust. +Use UPnP and similar to traverse NAT, like ‘filegive’ does. + +* user interface ** add guile-ncurses interface * extend <package> - ** add ‘recommends’ field For instance, glibc, binutils, gcc, and ld-wrapper would recommend each other. @@ -76,15 +64,10 @@ The Guildhall is Guile’s packaging system. It should be easy to add a ‘guildhall-build-system’ that does the right thing based on guildhall recipes. -* add ‘allowed-references’ in <package> - -[[file:~/src/nix/src/libstore/build.cc::if%20(drv.env.find("allowedReferences")%20!%3D%20drv.env.end())%20{][See how Nix implements that internally]]. - * union -Support sophisticated collision handling when building a union: check -whether the colliding files are identical, honor per-package priorities, -etc. +Support sophisticated collision handling when building a union: honor +per-package priorities, etc. * add GUIX_ALLOW_EXPENSIVE_TESTS @@ -96,7 +79,6 @@ run when that is defined. Would download a substitute, and compare its contents against a (hopefully locally-built) copy. - * guix build utils ** MAYBE Change ‘ld-wrapper’ to add RPATH for libs passed by file name @@ -107,13 +89,9 @@ locally-built) copy. See [[https://github.com/NixOS/nixpkgs/commit/d1662d715514e6ef9d3dc29f132f1b3d8e608a18][Shea Levy's `replace-dependency' in Nixpkgs]]. * distro -** port to new GNU/Linux platforms, notably ‘mipsel64-linux’ ** port to GNU/Hurd, aka. ‘i686-gnu’ Problems include that current glibc releases do not build on GNU/Hurd. In addition, there haven’t been stable releases of GNU Mach, MiG, and Hurd, which would be a pre-condition. -** make a bootable GNU/Linux-Libre distro, with OS configuration EDSL - -Similar in spirit to /etc/nixos/configuration.nix. diff --git a/doc/guix.texi b/doc/guix.texi index e3b0cf61f0..51884c3c6f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2850,8 +2850,7 @@ The system does not yet provide graphical desktop environments such as GNOME and KDE. @item -Support for encrypted disks, the Logical Volume Manager (LVM), and swap -devices is missing. +Support for the Logical Volume Manager (LVM) is missing. @item Few system services are currently supported out-of-the-box @@ -3040,6 +3039,7 @@ instance to support new system services. @menu * Using the Configuration System:: Customizing your GNU system. * File Systems:: Configuring file system mounts. +* Mapped Devices:: Block device extra processing. * User Accounts:: Specifying user accounts. * Services:: Specifying system services. * Setuid Programs:: Programs running with root privileges. @@ -3245,6 +3245,69 @@ and unmount user-space FUSE file systems. This requires the @code{fuse.ko} kernel module to be loaded. @end defvr +@node Mapped Devices +@subsection Mapped Devices + +@cindex device mapping +@cindex mapped devices +The Linux kernel has a notion of @dfn{device mapping}: a block device, +such as a hard disk partition, can be @dfn{mapped} into another device, +with additional processing over the data that flows through +it@footnote{Note that the GNU@tie{}Hurd makes no difference between the +concept of a ``mapped device'' and that of a file system: both boil down +to @emph{translating} input/output operations made on a file to +operations on its backing store. Thus, the Hurd implements mapped +devices, like file systems, using the generic @dfn{translator} mechanism +(@pxref{Translators,,, hurd, The GNU Hurd Reference Manual}).}. A +typical example is encryption device mapping: all writes to the mapped +device are encrypted, and all reads are deciphered, transparently. + +Mapped devices are declared using the @code{mapped-device} form: + +@example +(mapped-device + (source "/dev/sda3") + (target "home") + (type luks-device-mapping)) +@end example + +@noindent +@cindex disk encryption +@cindex LUKS +This example specifies a mapping from @file{/dev/sda3} to +@file{/dev/mapper/home} using LUKS---the +@url{http://code.google.com/p/cryptsetup,Linux Unified Key Setup}, a +standard mechanism for disk encryption. The @file{/dev/mapper/home} +device can then be used as the @code{device} of a @code{file-system} +declaration (@pxref{File Systems}). The @code{mapped-device} form is +detailed below. + +@deftp {Data Type} mapped-device +Objects of this type represent device mappings that will be made when +the system boots up. + +@table @code +@item source +This string specifies the name of the block device to be mapped, such as +@code{"/dev/sda3"}. + +@item target +This string specifies the name of the mapping to be established. For +example, specifying @code{"my-partition"} will lead to the creation of +the @code{"/dev/mapper/my-partition"} device. + +@item type +This must be a @code{mapped-device-kind} object, which specifies how +@var{source} is mapped to @var{target}. +@end table +@end deftp + +@defvr {Scheme Variable} luks-device-mapping +This defines LUKS block device encryption using the @command{cryptsetup} +command, from the same-named package. This relies on the +@code{dm-crypt} Linux kernel module. +@end defvr + @node User Accounts @subsection User Accounts @@ -3254,7 +3317,10 @@ User accounts are specified with the @code{user-account} form: (user-account (name "alice") (group "users") - (supplementary-groups '("wheel")) ; allow use of sudo, etc. + (supplementary-groups '("wheel" ;allow use of sudo, etc. + "audio" ;sound card + "video" ;video devices such as webcams + "cdrom")) ;the good ol' CD-ROM (comment "Bob's sister") (home-directory "/home/alice")) @end example @@ -3446,6 +3512,12 @@ Run @var{udev}, which populates the @file{/dev} directory dynamically. The @code{(gnu system networking)} module provides services to configure the network interface. +@cindex DHCP, networking service +@deffn {Monadic Procedure} dhcp-client-service [#:dhcp @var{isc-dhcp}] +Return a service that runs @var{dhcp}, a Dynamic Host Configuration +Protocol (DHCP) client, on all the non-loopback network interfaces. +@end deffn + @deffn {Monadic Procedure} static-networking-service @var{interface} @var{ip} @ [#:gateway #f] [#:name-services @code{'()}] Return a service that starts @var{interface} with address @var{ip}. If @@ -3577,23 +3649,24 @@ at boot time, you can define the @code{initrd} field of the operating system declaration like this: @example -(initrd (cut base-initrd <> - #:extra-modules '("my.ko" "modules.ko"))) +(initrd (lambda (file-systems . rest) + (apply base-initrd file-systems + #:extra-modules '("my.ko" "modules.ko") + rest))) @end example -@noindent -Note that for the example above, the SRFI-26 module needs to be imported -(@pxref{SRFI-26,,, guile, GNU Guile Reference Manual}). - -It also handles common use cases that involves using the system as a -QEMU guest, or as a ``live'' system whose root file system is volatile. +The @code{base-initrd} procedure also handles common use cases that +involves using the system as a QEMU guest, or as a ``live'' system whose +root file system is volatile. @deffn {Monadic Procedure} base-initrd @var{file-systems} @ [#:qemu-networking? #f] [#:virtio? #f] [#:volatile-root? #f] @ - [#:extra-modules '()] + [#:extra-modules '()] [#:mapped-devices '()] Return a monadic derivation that builds a generic initrd. @var{file-systems} is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified on the kernel command line via @code{--root}. +@var{mapped-devices} is a list of device mappings to realize before +@var{file-systems} are mounted (@pxref{Mapped Devices}). When @var{qemu-networking?} is true, set up networking with the standard QEMU parameters. When @var{virtio?} is true, load additional modules so the initrd can diff --git a/gnu-system.am b/gnu-system.am index 7d6763c5ec..67b13e7803 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -351,6 +351,7 @@ dist_patch_DATA = \ gnu/packages/patches/hop-bigloo-4.0b.patch \ gnu/packages/patches/icu4c-test-date-format.patch \ gnu/packages/patches/inkscape-stray-comma.patch \ + gnu/packages/patches/jbig2dec-ignore-testtest.patch \ gnu/packages/patches/kmod-module-directory.patch \ gnu/packages/patches/libbonobo-activation-test-race.patch \ gnu/packages/patches/libevent-dns-tests.patch \ @@ -371,6 +372,7 @@ dist_patch_DATA = \ gnu/packages/patches/mit-krb5-init-fix.patch \ gnu/packages/patches/mpc123-initialize-ao.patch \ gnu/packages/patches/module-init-tools-moduledir.patch \ + gnu/packages/patches/mupdf-buildsystem-fix.patch \ gnu/packages/patches/nvi-assume-preserve-path.patch \ gnu/packages/patches/orpheus-cast-errors-and-includes.patch \ gnu/packages/patches/ots-no-include-missing-file.patch \ @@ -405,7 +407,6 @@ dist_patch_DATA = \ gnu/packages/patches/texi2html-i18n.patch \ gnu/packages/patches/udev-gir-libtool.patch \ gnu/packages/patches/util-linux-perl.patch \ - gnu/packages/patches/valgrind-glibc.patch \ gnu/packages/patches/vpnc-script.patch \ gnu/packages/patches/w3m-fix-compile.patch \ gnu/packages/patches/xmodmap-asprintf.patch \ diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index 16805b9bc6..f46ff62d13 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -88,6 +88,33 @@ properties. Return #t on success." ,name))) (zero? (apply system* "useradd" args))))) +(define* (modify-user name group + #:key uid comment home shell password system? + (supplementary-groups '()) + (log-port (current-error-port))) + "Modify user account NAME to have all the given settings." + ;; Use 'usermod' from the Shadow package. + (let ((args `(,@(if uid `("-u" ,(number->string uid)) '()) + "-g" ,(if (number? group) (number->string group) group) + ,@(if (pair? supplementary-groups) + `("-G" ,(string-join supplementary-groups ",")) + '()) + ,@(if comment `("-c" ,comment) '()) + ;; Don't use '--move-home', so ignore HOME. + ,@(if shell `("-s" ,shell) '()) + ,name))) + (zero? (apply system* "usermod" args)))) + +(define* (ensure-user name group + #:key uid comment home shell password system? + (supplementary-groups '()) + (log-port (current-error-port)) + #:rest rest) + "Make sure user NAME exists and has the relevant settings." + (if (false-if-exception (getpwnam name)) + (apply modify-user name group rest) + (apply add-user name group rest))) + (define (activate-users+groups users groups) "Make sure the accounts listed in USERS and the user groups listed in GROUPS are all available. @@ -101,23 +128,22 @@ numeric gid or #f." (define activate-user (match-lambda ((name uid group supplementary-groups comment home shell password system?) - (unless (false-if-exception (getpwnam name)) - (let ((profile-dir (string-append "/var/guix/profiles/per-user/" - name))) - (add-user name group - #:uid uid - #:system? system? - #:supplementary-groups supplementary-groups - #:comment comment - #:home home - #:shell shell - #:password password) - - (unless system? - ;; Create the profile directory for the new account. - (let ((pw (getpwnam name))) - (mkdir-p profile-dir) - (chown profile-dir (passwd:uid pw) (passwd:gid pw))))))))) + (let ((profile-dir (string-append "/var/guix/profiles/per-user/" + name))) + (ensure-user name group + #:uid uid + #:system? system? + #:supplementary-groups supplementary-groups + #:comment comment + #:home home + #:shell shell + #:password password) + + (unless system? + ;; Create the profile directory for the new account. + (let ((pw (getpwnam name))) + (mkdir-p profile-dir) + (chown profile-dir (passwd:uid pw) (passwd:gid pw)))))))) ;; 'groupadd' aborts if the file doesn't already exist. (touch "/etc/group") diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 5c04771e19..4ac7a7f8c6 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -233,7 +233,7 @@ the following: (define fsck (string-append "fsck." type)) - (let ((status (system* fsck "-v" "-p" device))) + (let ((status (system* fsck "-v" "-p" "-C" "0" device))) (match (status:exit-val status) (0 #t) diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index fbc683c798..a58232c815 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -339,24 +339,21 @@ bailing out.~%root contents: ~s~%" (scandir "/")) (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? - guile-modules-in-chroot? volatile-root? + pre-mount (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES (a list of absolute file names of '.ko' files), then setting up QEMU guest networking if QEMU-GUEST-NETWORKING? is true, -mounting the file systems specified in MOUNTS, and finally booting into the -new root if any. The initrd supports kernel command-line options '--load', -'--root', and '--repl'. +calling PRE-MOUNT, mounting the file systems specified in MOUNTS, and finally +booting into the new root if any. The initrd supports kernel command-line +options '--load', '--root', and '--repl'. Mount the root file system, specified by the '--root' command-line argument, if any. MOUNTS must be a list suitable for 'mount-file-system'. -When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in -the new root. - When VOLATILE-ROOT? is true, the root file system is writable but any changes to it are lost." (define root-mount-point? @@ -407,23 +404,15 @@ to it are lost." (mkdir "/root/dev") (make-essential-device-nodes #:root "/root")) + (when (procedure? pre-mount) + ;; Do whatever actions are needed before mounting--e.g., installing + ;; device mappings. + (pre-mount)) + ;; Mount the specified file systems. (for-each mount-file-system (remove root-mount-point? mounts)) - (when guile-modules-in-chroot? - ;; Copy the directories that contain .scm and .go files so that the - ;; child process in the chroot can load modules (we would bind-mount - ;; them but for some reason that fails with EINVAL -- XXX). - (mkdir-p "/root/share") - (mkdir-p "/root/lib") - (mount "none" "/root/share" "tmpfs") - (mount "none" "/root/lib" "tmpfs") - (copy-recursively "/share" "/root/share" - #:log (%make-void-port "w")) - (copy-recursively "/lib" "/root/lib" - #:log (%make-void-port "w"))) - (if to-load (begin (switch-root "/root") diff --git a/gnu/packages/algebra.scm b/gnu/packages/algebra.scm index 7fc31abae7..53382eb67b 100644 --- a/gnu/packages/algebra.scm +++ b/gnu/packages/algebra.scm @@ -205,6 +205,49 @@ fast arithmetic.") (license gpl2+) (home-page "http://flintlib.org/"))) +(define-public arb + (package + (name "arb") + (version "2.2.0") + (source (origin + (method url-fetch) + (uri (string-append + "https://github.com/fredrik-johansson/arb/archive/" + version ".tar.gz")) + (sha256 (base32 + "0a8cgzznkmr59ngj4di9a37b5h4i00gbnixnxlwd34bcbflvjzyr")))) + (build-system gnu-build-system) + (inputs + `(("flint" ,flint) + ("gmp" ,gmp) + ("mpfr" ,mpfr))) + (arguments + `(#:phases + (alist-replace + 'configure + (lambda* (#:key inputs outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out")) + (flint (assoc-ref inputs "flint")) + (gmp (assoc-ref inputs "gmp")) + (mpfr (assoc-ref inputs "mpfr"))) + ;; do not pass "--enable-fast-install", which makes the + ;; homebrew configure process fail + (zero? (system* + "./configure" + (string-append "--prefix=" out) + (string-append "--with-flint=" flint) + (string-append "--with-gmp=" gmp) + (string-append "--with-mpfr=" mpfr))))) + %standard-phases))) + (synopsis "Arbitrary precision floating-point ball arithmetic") + (description + "Arb is a C library for arbitrary-precision floating-point ball +arithmetic. It supports efficient high-precision computation with +polynomials, power series, matrices and special functions over the +real and complex numbers, with automatic, rigorous error control.") + (license gpl2+) + (home-page "http://fredrikj.net/arb/"))) + (define-public bc (package (name "bc") diff --git a/gnu/packages/backup.scm b/gnu/packages/backup.scm index 5c44786af3..d6e106071f 100644 --- a/gnu/packages/backup.scm +++ b/gnu/packages/backup.scm @@ -34,6 +34,7 @@ #:use-module (gnu packages nettle) #:use-module (gnu packages pcre) #:use-module (gnu packages python) + #:use-module (gnu packages linux) #:use-module (gnu packages pkg-config) #:use-module (gnu packages rsync) #:use-module (gnu packages ssh) @@ -56,7 +57,8 @@ "0l14nrhbgkyjgvh339bbhnm6hrdwrjadphq1jmpi0mcgcdbdfh8x")))) (build-system python-build-system) (native-inputs - `(("python2-setuptools" ,python2-setuptools))) + `(("python2-setuptools" ,python2-setuptools) + ("util-linux" ,util-linux))) ;setsid command, for the tests (inputs `(("python" ,python-2) ("librsync" ,librsync) diff --git a/gnu/packages/cdrom.scm b/gnu/packages/cdrom.scm index 518cfc3c2b..7c62e59626 100644 --- a/gnu/packages/cdrom.scm +++ b/gnu/packages/cdrom.scm @@ -163,7 +163,7 @@ files.") (synopsis "audio CD reading utility which includes extra data verification features") (description "Cdparanoia retrieves audio tracks from CDDA capable CDROM drives. The data can be saved to a file or directed to standard output -in WAV, AIFF, AIFF-C or raw format. Most ATAPI, SCSI and several +in WAV, AIFF, AIFF-C or raw format. Most ATAPI, SCSI and several proprietary CDROM drive makes are supported; cdparanoia can determine if the target drive is CDDA capable. In addition to simple reading, cdparanoia adds extra-robust data verification, synchronization, error handling and scratch diff --git a/gnu/packages/emacs.scm b/gnu/packages/emacs.scm index 1a37bef657..a788bd8fde 100644 --- a/gnu/packages/emacs.scm +++ b/gnu/packages/emacs.scm @@ -79,7 +79,7 @@ ;; TODO: Add the optional dependencies. ("xlibs" ,libx11) - ("gtk+" ,gtk+-2) + ("gtk+" ,gtk+) ("libXft" ,libxft) ("libtiff" ,libtiff) ("giflib" ,giflib) diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm index 1169158113..e928c311e4 100644 --- a/gnu/packages/guile.scm +++ b/gnu/packages/guile.scm @@ -359,27 +359,25 @@ http:://json.org specification. These are the main features: (define-public guile-charting (package (name "guile-charting") - (version "0.1.1") + (version "0.2.0") (source (origin (method url-fetch) (uri (string-append "http://wingolog.org/pub/guile-charting/" "guile-charting-" version ".tar.gz")) (sha256 (base32 - "1l8xcqq4cp67jzxnmf07ivsgq23mfmi00zz1s8bnv2zkb0ab9475")) + "0w5qiyv9v0ip5li22x762bm48g8xnw281w66iyw094zdw611pb2m")) (modules '((guix build utils))) (snippet - ;; Remove dependency from guile-charting.texi to - ;; guile-chartingscmfiles to avoid rebuild the doc (which is - ;; unnecessary and fails with "failed to match any pattern in - ;; form define-macro-with-docs" as of Guile 2.0.11.) - '(substitute* "doc/Makefile.in" - (("^(.+):(.*) \\$\\(doc\\)scmfiles(.*$)" _ target dep1 dep2) - (string-append target ":" dep1 " " dep2 "\n")))))) + '(begin + ;; Use the standard location for modules. + (substitute* "Makefile.in" + (("godir = .*$") + "godir = $(moddir)\n")))))) (build-system gnu-build-system) (native-inputs `(("pkg-config" ,pkg-config))) - (inputs `(("guile" ,guile-2.0) - ("guile-cairo" ,guile-cairo))) + (inputs `(("guile" ,guile-2.0))) + (propagated-inputs `(("guile-cairo" ,guile-cairo))) (home-page "http://wingolog.org/software/guile-charting/") (synopsis "Create charts and graphs in Guile") (description diff --git a/gnu/packages/image.scm b/gnu/packages/image.scm index 149720e5e8..a55a5456af 100644 --- a/gnu/packages/image.scm +++ b/gnu/packages/image.scm @@ -22,10 +22,12 @@ #:use-module (gnu packages fontutils) #:use-module (gnu packages pkg-config) #:use-module (gnu packages xml) + #:use-module (gnu packages ghostscript) ;lcms #:use-module ((guix licenses) #:renamer (symbol-prefix-proc 'license:)) #:use-module (guix packages) #:use-module (guix download) - #:use-module (guix build-system gnu)) + #:use-module (guix build-system gnu) + #:use-module (guix build-system cmake)) (define-public libpng (package @@ -146,3 +148,68 @@ the W3C's XML-based Scaleable Vector Graphic (SVG) format.") ;; 'COPYING' is the GPLv2, but file headers say LGPLv2.0+. (license license:lgpl2.0+))) + +(define-public jbig2dec + (package + (name "jbig2dec") + (version "0.11") + (source + (origin + (method url-fetch) + (uri ;; The link on the homepage is dead. + (string-append "http://distfiles.gentoo.org/distfiles/" name "-" + version ".tar.gz")) + (sha256 + (base32 "1ffhgmf2fqzk0h4k736pp06z7q5y4x41fg844bd6a9vgncq86bby")) + (patches (list (search-patch "jbig2dec-ignore-testtest.patch"))))) + + (build-system gnu-build-system) + (synopsis "Decoder of the JBIG2 image compression format") + (description + "JBIG2 is designed for lossy or lossless encoding of 'bilevel' +(1-bit monochrome) images at moderately high resolution, and in +particular scanned paper documents. In this domain it is very +efficient, offering compression ratios on the order of 100:1. + +This is a decoder only implementation, and currently is in the alpha +stage, meaning it doesn't completely work yet. However, it is +maintaining parity with available encoders, so it is useful for real +work.") + (home-page "http://jbig2dec.sourceforge.net/") + (license license:gpl2+))) + +(define-public openjpeg + (package + (name "openjpeg") + (version "2.0.0") + (source + (origin + (method url-fetch) + (uri + (string-append "http://openjpeg.googlecode.com/files/" name "-" + version ".tar.gz")) + (sha256 + (base32 "1n05yrmscpgksrh2kfh12h18l0lw9j03mgmvwcg3hm8m0lwgak9k")))) + + (build-system cmake-build-system) + (arguments + ;; Trying to run `$ make check' results in a no rule fault. + '(#:tests? #f)) + (inputs + `(("lcms" ,lcms) + ("libpng" ,libpng) + ("libtiff" ,libtiff) + ("zlib" ,zlib))) + (synopsis "JPEG 2000 codec") + (description + "The OpenJPEG library is a JPEG 2000 codec written in C. It has +been developed in order to promote the use of JPEG 2000, the new +still-image compression standard from the Joint Photographic Experts +Group (JPEG). + +In addition to the basic codec, various other features are under +development, among them the JP2 and MJ2 (Motion JPEG 2000) file formats, +an indexing tool useful for the JPIP protocol, JPWL-tools for +error-resilience, a Java-viewer for j2k-images, ...") + (home-page "http://jbig2dec.sourceforge.net/") + (license license:bsd-2))) diff --git a/gnu/packages/libcanberra.scm b/gnu/packages/libcanberra.scm index 1106a8aa83..764c3272a2 100644 --- a/gnu/packages/libcanberra.scm +++ b/gnu/packages/libcanberra.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,7 +25,9 @@ #:use-module (gnu packages autotools) #:use-module (gnu packages gstreamer) #:use-module (gnu packages gtk) + #:use-module (gnu packages glib) #:use-module (gnu packages linux) + #:use-module (gnu packages pulseaudio) #:use-module (gnu packages pkg-config) #:use-module (gnu packages xiph)) @@ -35,19 +38,24 @@ (source (origin (method url-fetch) - (uri (string-append "http://0pointer.de/lennart/projects/libcanberra/libcanberra-" - version ".tar.xz")) + + ;; This used to be at 0pointer.de but it vanished. + (uri (string-append + "http://pkgs.fedoraproject.org/repo/pkgs/libcanberra/libcanberra-" + version ".tar.xz/34cb7e4430afaf6f447c4ebdb9b42072/libcanberra-" + version ".tar.xz")) (sha256 (base32 "0wps39h8rx2b00vyvkia5j40fkak3dpipp1kzilqla0cgvk73dn2")))) (build-system gnu-build-system) (inputs - ;; FIXME: Add optional inputs udev and pulse. `(("alsa-lib" ,alsa-lib) ("gstreamer" ,gstreamer) ("gtk+" ,gtk+) ("libtool" ,libtool) - ("libvorbis" ,libvorbis))) + ("libvorbis" ,libvorbis) + ("pulseaudio" ,pulseaudio) + ("udev" ,eudev))) (native-inputs `(("pkg-config" ,pkg-config))) (home-page "http://0pointer.de/lennart/projects/libcanberra/") @@ -59,3 +67,23 @@ Specifications, for generating event sounds on free desktops, such as GNOME. It comes with several backends (ALSA, PulseAudio, OSS, GStreamer, null) and is designed to be portable.") (license lgpl2.1+))) + +(define-public sound-theme-freedesktop + (package + (name "sound-theme-freedesktop") + (version "0.8") + (source (origin + (method url-fetch) + (uri (string-append "http://people.freedesktop.org/~mccann/dist/" + name "-" version ".tar.bz2")) + (sha256 + (base32 + "054abv4gmfk9maw93fis0bf605rc56dah7ys5plc4pphxqh8nlfb")))) + (build-system gnu-build-system) + (native-inputs `(("intltool" ,intltool))) + (synopsis "Audio samples for use as a desktop sound theme") + (description + "This package provides audio samples that can be used by libcanberra as +sounds for various system events.") + (license #f) + (home-page "http://www.freedesktop.org/wiki/Specifications/sound-theme-spec/"))) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index dd4ed85a64..561275c05f 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -190,7 +190,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM." #f))) (define-public linux-libre - (let* ((version "3.16.2") + (let* ((version "3.16.3") (build-phase '(lambda* (#:key system inputs #:allow-other-keys #:rest args) ;; Apply the neat patch. @@ -263,7 +263,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM." (uri (linux-libre-urls version)) (sha256 (base32 - "1p08cqy6427yi808fpbwbb4zbwhnkibj2i1wbrfa5rjhd4vnnffz")))) + "1480wnk1j18rxhp8hi7dd4d706lkgplwhvskx3z2mj39vg46v1zk")))) (build-system gnu-build-system) (native-inputs `(("perl" ,perl) ("bc" ,bc) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 5f30afe433..af9feff040 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -273,7 +273,7 @@ plotting engine by third-party applications like Octave.") %standard-phases))) (outputs '("out" "bin" "lib" "include")) (home-page "http://www.hdfgroup.org") - (synopsis "Management suite for extremely large and complex data") + (synopsis "Management suite for extremely large and complex data") (description "HDF5 is a suite that makes possible the management of extremely large and complex data collections.") (license (license:x11-style diff --git a/gnu/packages/ocaml.scm b/gnu/packages/ocaml.scm index bcd4c196c5..b4e48ccc4c 100644 --- a/gnu/packages/ocaml.scm +++ b/gnu/packages/ocaml.scm @@ -23,7 +23,11 @@ #:use-module (guix download) #:use-module (guix build-system gnu) #:use-module (gnu packages) - #:use-module (gnu packages perl)) + #:use-module (gnu packages perl) + #:use-module (gnu packages python) + #:use-module (gnu packages ncurses) + #:use-module (gnu packages version-control) + #:use-module (gnu packages curl)) (define-public ocaml (package @@ -78,3 +82,64 @@ an emphasis on expressiveness and safety. Developed for more than 20 years at Inria it benefits from one of the most advanced type systems and supports functional, imperative and object-oriented styles of programming.") (license (list qpl gpl2)))) + +(define-public opam + (package + (name "opam") + (version "1.1.1") + (source (origin + (method url-fetch) + ;; Use the '-full' version, which includes all the dependencies. + (uri (string-append + "https://github.com/ocaml/opam/releases/download/" + version "/opam-full-" version ".tar.gz") + ;; (string-append "https://github.com/ocaml/opam/archive/" + ;; version ".tar.gz") + ) + (sha256 + (base32 + "1frzqkx6yn1pnyd9qz3bv3rbwv74bmc1xji8kl41r1dkqzfl3xqv")))) + (build-system gnu-build-system) + (arguments + '(;; Sometimes, 'make -jX' would fail right after ./configure with + ;; "Fatal error: exception End_of_file". + #:parallel-build? #f + + ;; For some reason, 'ocp-build' needs $TERM to be set. + #:make-flags '("TERM=screen") + #:test-target "tests" + + ;; FIXME: There's an obscure test failure: + ;; …/_obuild/opam/opam.asm install P1' failed. + #:tests? #f + + #:phases (alist-cons-before + 'build 'pre-build + (lambda* (#:key inputs #:allow-other-keys) + (let ((bash (assoc-ref inputs "bash"))) + (substitute* "src/core/opamSystem.ml" + (("\"/bin/sh\"") + (string-append "\"" bash "/bin/sh\""))))) + (alist-cons-before + 'check 'pre-check + (lambda _ + (setenv "HOME" (getcwd)) + (and (system "git config --global user.email guix@gnu.org") + (system "git config --global user.name Guix"))) + %standard-phases)))) + (native-inputs + `(("git" ,git) ;for the tests + ("python" ,python))) ;for the tests + (inputs + `(("ocaml" ,ocaml) + ("ncurses" ,ncurses) + ("curl" ,curl))) + (home-page "http://opam.ocamlpro.com/") + (synopsis "Package manager for OCaml") + (description + "OPAM is a tool to manage OCaml packages. It supports multiple +simultaneous compiler installations, flexible package constraints, and a +Git-friendly development workflow.") + + ;; The 'LICENSE' file waives some requirements compared to LGPLv3. + (license lgpl3))) diff --git a/gnu/packages/ots.scm b/gnu/packages/ots.scm index cd2bf8585b..4404841375 100644 --- a/gnu/packages/ots.scm +++ b/gnu/packages/ots.scm @@ -45,6 +45,10 @@ (list (search-patch "ots-no-include-missing-file.patch"))))) (build-system gnu-build-system) + (arguments + ;; With '-jN', the rule to build the 'ots' command can be triggered + ;; before libots-1.la has been built. + '(#:parallel-build? #f)) (inputs `(("glib" ,glib) ("popt" ,popt) diff --git a/gnu/packages/patches/jbig2dec-ignore-testtest.patch b/gnu/packages/patches/jbig2dec-ignore-testtest.patch new file mode 100644 index 0000000000..1bf8f7ad76 --- /dev/null +++ b/gnu/packages/patches/jbig2dec-ignore-testtest.patch @@ -0,0 +1,14 @@ +Do not run the "testtest script", it doesn't seem to do anything and reports +failiute. TODO: Actually fix the test instead of ignoring it. + +--- a/Makefile.in 2010-02-02 20:13:56.000000000 +0100 ++++ b/Makefile.in 2014-09-13 17:50:10.957816767 +0200 +@@ -181,7 +181,7 @@ + + MAINTAINERCLEANFILES = config_types.h.in + +-TESTS = test_sha1 test_jbig2dec.py test_huffman test_arith ++TESTS = test_sha1 test_huffman test_arith + + test_sha1_SOURCES = sha1.c sha1.h + test_sha1_CFLAGS = -DTEST diff --git a/gnu/packages/patches/mupdf-buildsystem-fix.patch b/gnu/packages/patches/mupdf-buildsystem-fix.patch new file mode 100644 index 0000000000..0b17dda911 --- /dev/null +++ b/gnu/packages/patches/mupdf-buildsystem-fix.patch @@ -0,0 +1,69 @@ +Since openjpeg doesn't seem to ship with a .pc file, provide an alternative. + +--- a/ojp2_cppflags.sh 1970-01-01 01:00:00.000000000 +0100 ++++ b/ojp2_cppflags.sh 2014-09-13 22:56:38.842418777 +0200 +@@ -0,0 +1,7 @@ ++#!/bin/sh ++ ++# Return the preprocessor flags to link against openjpeg. ++ ++cpppath=$(echo ${NIX_STORE}/*-openjpeg-*/include/openjpeg-*) ++ ++echo -I$cpppath + +--- a/ojp2_ldflags.sh 1970-01-01 01:00:00.000000000 +0100 ++++ b/ojp2_ldflags.sh 2014-09-13 22:56:38.842418777 +0200 +@@ -0,0 +1,7 @@ ++#!/bin/sh ++ ++# Return the linker flags to link against openjpeg. ++ ++ldpath=$(echo ${NIX_STORE}/*-openjpeg-*/lib) ++ ++echo -L$ldpath -lopenjp2 + +Make use of the above alternatives, compile with gcc. + +--- a/Makerules 2014-09-14 09:13:40.729149860 +0200 ++++ b/Makerules 2014-09-14 09:17:06.425156595 +0200 +@@ -75,12 +75,14 @@ + + SYS_FREETYPE_CFLAGS = $(shell pkg-config --cflags freetype2) + SYS_FREETYPE_LIBS = $(shell pkg-config --libs freetype2) +-SYS_OPENJPEG_CFLAGS = $(shell pkg-config --cflags libopenjp2) +-SYS_OPENJPEG_LIBS = $(shell pkg-config --libs libopenjp2) ++SYS_OPENJPEG_CFLAGS = $(shell ./ojp2_cppflags.sh) ++SYS_OPENJPEG_LIBS = $(shell ./ojp2_ldflags.sh) + SYS_JBIG2DEC_LIBS = -ljbig2dec + SYS_JPEG_LIBS = -ljpeg + SYS_ZLIB_LIBS = -lz + ++CC = gcc ++ + endif + + # The following section is an example of how to simply do cross-compilation + +Remove the -x11 from the built binaries, since X11 is implied on GNU. (This +might change when Wayland gets more popular) + +--- a/Makefile 2014-06-10 17:09:28.000000000 +0200 ++++ b/Makefile 2014-09-14 09:57:10.381235299 +0200 +@@ -255,7 +255,7 @@ + $(LINK_CMD) + + ifeq "$(HAVE_X11)" "yes" +-MUVIEW_X11 := $(OUT)/mupdf-x11 ++MUVIEW_X11 := $(OUT)/mupdf + MUVIEW_X11_OBJ := $(addprefix $(OUT)/platform/x11/, x11_main.o x11_image.o pdfapp.o) + $(MUVIEW_X11_OBJ) : $(FITZ_HDR) $(PDF_HDR) + $(MUVIEW_X11) : $(MUPDF_LIB) $(THIRD_LIBS) +@@ -263,7 +263,7 @@ + $(LINK_CMD) $(X11_LIBS) + + ifeq "$(HAVE_CURL)" "yes" +-MUVIEW_X11_CURL := $(OUT)/mupdf-x11-curl ++MUVIEW_X11_CURL := $(OUT)/mupdf-curl + MUVIEW_X11_CURL_OBJ := $(addprefix $(OUT)/platform/x11/curl/, x11_main.o x11_image.o pdfapp.o curl_stream.o) + $(MUVIEW_X11_CURL_OBJ) : $(FITZ_HDR) $(PDF_HDR) + $(MUVIEW_X11_CURL) : $(MUPDF_LIB) $(THIRD_LIBS) $(CURL_LIB) diff --git a/gnu/packages/patches/valgrind-glibc.patch b/gnu/packages/patches/valgrind-glibc.patch deleted file mode 100644 index 47a415bb8f..0000000000 --- a/gnu/packages/patches/valgrind-glibc.patch +++ /dev/null @@ -1,21 +0,0 @@ -Accept glibc 2.19 as valid. - ---- a/configure 2013-10-10 22:27:20.331223000 +0200 -+++ b/configure 2013-10-10 22:27:55.055223000 +0200 -@@ -6604,6 +6604,16 @@ - DEFAULT_SUPP="glibc-2.34567-NPTL-helgrind.supp ${DEFAULT_SUPP}" - DEFAULT_SUPP="glibc-2.X-drd.supp ${DEFAULT_SUPP}" - ;; -+ 2.19) -+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: 2.19 family" >&5 -+$as_echo "2.19 family" >&6; } -+ -+$as_echo "#define GLIBC_2_18 1" >>confdefs.h -+ -+ DEFAULT_SUPP="glibc-2.X.supp ${DEFAULT_SUPP}" -+ DEFAULT_SUPP="glibc-2.34567-NPTL-helgrind.supp ${DEFAULT_SUPP}" -+ DEFAULT_SUPP="glibc-2.X-drd.supp ${DEFAULT_SUPP}" -+ ;; - darwin) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: Darwin" >&5 - $as_echo "Darwin" >&6; } diff --git a/gnu/packages/pdf.scm b/gnu/packages/pdf.scm index 82331a1d0a..c3cb755f4d 100644 --- a/gnu/packages/pdf.scm +++ b/gnu/packages/pdf.scm @@ -35,6 +35,7 @@ #:use-module (gnu packages glib) #:use-module (gnu packages gtk) #:use-module (gnu packages lua) + #:use-module (gnu packages curl) #:use-module (srfi srfi-1)) (define-public poppler @@ -159,3 +160,69 @@ it easy to modify them and write the changes to disk. It is primarily useful for applications that wish to do lower level manipulation of PDF, such as extracting content or merging files.") (license license:lgpl2.0+))) + +(define-public mupdf + (package + (name "mupdf") + (version "1.5") + (source + (origin + (method url-fetch) + (uri (string-append "http://mupdf.com/downloads/" name "-" version + "-source.tar.gz")) + (sha256 + (base32 "0sl47zqf4c9fhs4h5zg046vixjmwgy4vhljhr5g4md733nash7z4")) + (patches + (list (search-patch "mupdf-buildsystem-fix.patch"))) + (modules '((guix build utils))) + (snippet + '(begin + ;; Don't build the bundled-in third party libraries. + (delete-file-recursively "thirdparty") + + ;; Make the scripts for finding openjpeg build details executable. + (chmod "ojp2_cppflags.sh" #o0755) + (chmod "ojp2_ldflags.sh" #o0755))))) + + (build-system gnu-build-system) + (inputs + `(("curl" ,curl) + ("freetype" ,freetype) + ("jbig2dec" ,jbig2dec) + ("libjpeg" ,libjpeg) + ("libx11" ,libx11) + ("libxext" ,libxext) + ("openjpeg" ,openjpeg) + ("openssl" ,openssl) + ("zlib" ,zlib))) + (native-inputs + `(("pkg-config" ,pkg-config))) + (arguments + ;; Trying to run `$ make check' results in a no rule fault. + '(#:tests? #f + + #:modules ((guix build gnu-build-system) + (guix build utils) + (srfi srfi-1)) + #:phases (alist-replace + 'build + (lambda _ (zero? (system* "make" "XCFLAGS=-fpic"))) + (alist-replace + 'install + (lambda* (#:key outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (zero? (system* "make" (string-append "prefix=" out) + "install")))) + (alist-delete 'configure %standard-phases))))) + (home-page "http://mupdf.com") + (synopsis "Lightweight PDF viewer and toolkit") + (description + "MuPDF is a C library that implements a PDF and XPS parsing and +rendering engine. It is used primarily to render pages into bitmaps, +but also provides support for other operations such as searching and +listing the table of contents and hyperlinks. + +The library ships with a rudimentary X11 viewer, and a set of command +line tools for batch rendering (pdfdraw), examining the file structure +(pdfshow), and rewriting files (pdfclean).") + (license license:agpl3+))) diff --git a/gnu/packages/pulseaudio.scm b/gnu/packages/pulseaudio.scm index e37f7c07e3..b17ee6987f 100644 --- a/gnu/packages/pulseaudio.scm +++ b/gnu/packages/pulseaudio.scm @@ -121,7 +121,14 @@ rates. ") version ".tar.xz")) (sha256 (base32 - "0fgrr8v7yfh0byhzdv4c87v9lkj8g7gpjm8r9xrbvpa92a5kmhcr")))) + "0fgrr8v7yfh0byhzdv4c87v9lkj8g7gpjm8r9xrbvpa92a5kmhcr")) + (modules '((guix build utils))) + (snippet + ;; Disable console-kit support by default since it's deprecated + ;; anyway. + '(substitute* "src/daemon/default.pa.in" + (("load-module module-console-kit" all) + (string-append "#" all "\n")))))) (build-system gnu-build-system) (arguments `(#:configure-flags '("--localstatedir=/var" ;"--sysconfdir=/etc" diff --git a/gnu/packages/skribilo.scm b/gnu/packages/skribilo.scm index e9c213cbb2..6971e792d0 100644 --- a/gnu/packages/skribilo.scm +++ b/gnu/packages/skribilo.scm @@ -43,6 +43,22 @@ '(#:configure-flags (list (string-append "--with-guilemoduledir=" (assoc-ref %outputs "out") "/share/guile/site/2.0")) + + #:phases (alist-cons-before + 'configure 'pre-configure + (lambda* (#:key inputs #:allow-other-keys) + ;; Make sure the 'skribilo' command gets to see + ;; Guile-Reader, even if Guile-Reader is not in the search + ;; path. + (let ((reader (assoc-ref inputs "guile-reader"))) + (substitute* "src/skribilo.in" + (("^exec (.*) -c" _ things) + (string-append "exec " things + " -L " reader "/share/guile/site/2.0" + " -C " reader "/share/guile/site/2.0" + " -c"))))) + %standard-phases) + #:parallel-build? #f)) ;; TODO: Add Ploticus. (inputs `(("guile" ,guile-2.0) diff --git a/gnu/packages/tcl.scm b/gnu/packages/tcl.scm index d7ac10cb16..099bad25f9 100644 --- a/gnu/packages/tcl.scm +++ b/gnu/packages/tcl.scm @@ -161,8 +161,8 @@ X11 GUIs.") (home-page "http://www.tcl.tk/") (synopsis "Graphical user interface toolkit for Tcl") (description - "Tk is a graphical toolkit for building graphical user interfaces -(GUIs) in the Tcl language.") + "Tk is a graphical toolkit for building graphical user +interfaces (GUIs) in the Tcl language.") (license (package-license tcl)))) (define-public perl-tk @@ -185,7 +185,10 @@ X11 GUIs.") ("libjpeg" ,libjpeg))) (arguments `(#:make-maker-flags `(,(string-append - "X11=" (assoc-ref %build-inputs "libx11"))))) + "X11=" (assoc-ref %build-inputs "libx11"))) + + ;; Fails to build in parallel: <http://bugs.gnu.org/18262>. + #:parallel-build? #f)) (synopsis "Graphical user interface toolkit for Perl") (description "Tk is a Graphical User Interface ToolKit.") diff --git a/gnu/packages/valgrind.scm b/gnu/packages/valgrind.scm index 183adb0271..82e3b80f7f 100644 --- a/gnu/packages/valgrind.scm +++ b/gnu/packages/valgrind.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,15 +28,14 @@ (define-public valgrind (package (name "valgrind") - (version "3.9.0") + (version "3.10.0") (source (origin (method url-fetch) (uri (string-append "http://valgrind.org/downloads/valgrind-" version ".tar.bz2")) (sha256 (base32 - "1w6n5qvxy2ssbczcl1c2yd2ggjn3ipay2hvpn10laly2dfh73bz6")) - (patches (list (search-patch "valgrind-glibc.patch"))))) + "1jgd42vsx0bcblp91bd61hd5wpy0gghh09wxgm65m666vy17y103")))) (build-system gnu-build-system) (arguments '(#:phases (alist-cons-after diff --git a/gnu/services.scm b/gnu/services.scm index 6bb21722b6..37ecc019ec 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu services) + #:use-module (guix gexp) #:use-module (guix records) #:export (service? service @@ -47,9 +48,9 @@ (default '())) (respawn? service-respawn? ; Boolean (default #t)) - (start service-start) ; g-expression - (stop service-stop ; g-expression - (default #f)) + (start service-start) ; g-expression (procedure) + (stop service-stop ; g-expression (procedure) + (default #~(const #f))) (user-accounts service-user-accounts ; list of <user-account> (default '())) (user-groups service-user-groups ; list of <user-groups> diff --git a/gnu/services/base.scm b/gnu/services/base.scm index c40bc1a4c2..57a79a7749 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -39,6 +39,7 @@ #:export (root-file-system-service file-system-service device-mapping-service + swap-service user-processes-service host-name-service console-font-service @@ -137,6 +138,10 @@ names such as device-mapping services." (stop #~(lambda args ;; Normally there are no processes left at this point, so ;; TARGET can be safely unmounted. + + ;; Make sure PID 1 doesn't keep TARGET busy. + (chdir "/") + (umount #$target) #f)))))) @@ -182,6 +187,8 @@ stopped before 'kill' is called." (@ (ice-9 rdelim) read-string)))) '())) + (define lset= (@ (srfi srfi-1) lset=)) + ;; When this happens, all the processes have been ;; killed, including 'deco', so DMD-OUTPUT-PORT and ;; thus CURRENT-OUTPUT-PORT are dangling. @@ -206,6 +213,15 @@ stopped before 'kill' is called." (kill-except omitted-pids SIGKILL) (delete-file #$%do-not-kill-file))) + (let wait () + (let ((pids (processes))) + (unless (lset= = pids (cons 1 omitted-pids)) + (format #t "waiting for process termination\ + (processes left: ~s)~%" + pids) + (sleep 2) + (wait)))) + (display "all processes have been terminated\n") #f)) (respawn? #f))))) @@ -402,7 +418,7 @@ starting at FIRST-UID, and under GID." ;; guix-daemon expects GROUP to be listed as a ;; supplementary group too: ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>. - (supplementary-groups (list group)) + (supplementary-groups (list group "kvm")) (comment (format #f "Guix Build User ~2d" n)) (home-directory "/var/empty") @@ -510,10 +526,31 @@ item of @var{packages}." (guix build utils)) #:local-build? #t)) +(define* (kvm-udev-rule) + "Return a directory with a udev rule that changes the group of +@file{/dev/kvm} to \"kvm\" and makes it #o660." + ;; Apparently QEMU-KVM used to ship this rule, but now we have to add it by + ;; ourselves. + (gexp->derivation "kvm-udev-rules" + #~(begin + (use-modules (guix build utils)) + + (define rules.d + (string-append #$output "/lib/udev/rules.d")) + + (mkdir-p rules.d) + (call-with-output-file + (string-append rules.d "/90-kvm.rules") + (lambda (port) + (display "\ +KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port)))) + #:modules '((guix build utils)))) + (define* (udev-service #:key (udev eudev) (rules '())) "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get extra rules from the packages listed in @var{rules}." - (mlet* %store-monad ((rules (udev-rules-union (cons udev rules))) + (mlet* %store-monad ((kvm (kvm-udev-rule)) + (rules (udev-rules-union (cons* udev kvm rules))) (udev.conf (text-file* "udev.conf" "udev_rules=\"" rules "/lib/udev/rules.d\"\n"))) @@ -558,7 +595,8 @@ extra rules from the packages listed in @var{rules}." ;; The first one is for udev, the second one for eudev. (setenv "UDEV_CONFIG_FILE" #$udev.conf) - (setenv "EUDEV_RULES_DIRECTORY" #$rules) + (setenv "EUDEV_RULES_DIRECTORY" + (string-append #$rules "/lib/udev/rules.d")) (let ((pid (primitive-fork))) (case pid @@ -578,21 +616,46 @@ extra rules from the packages listed in @var{rules}." (system* (string-append #$udev "/bin/udevadm") "settle") pid))))) - (stop #~(make-kill-destructor)))))) + (stop #~(make-kill-destructor)) + + ;; When halting the system, 'udev' is actually killed by + ;; 'user-processes', i.e., before its own 'stop' method was + ;; called. Thus, make sure it is not respawned. + (respawn? #f))))) -(define (device-mapping-service target command) +(define (device-mapping-service target open close) "Return a service that maps device @var{target}, a string such as -@code{\"home\"} (meaning @code{/dev/mapper/home}), by executing @var{command}, -a gexp." +@code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a +gexp, to open it, and evaluate @var{close} to close it." (with-monad %store-monad (return (service (provision (list (symbol-append 'device-mapping- (string->symbol target)))) (requirement '(udev)) (documentation "Map a device node using Linux's device mapper.") + (start #~(lambda () #$open)) + (stop #~(lambda _ (not #$close))) + (respawn? #f))))) + +(define (swap-service device) + "Return a service that uses @var{device} as a swap device." + (define requirement + (if (string-prefix? "/dev/mapper/" device) + (list (symbol-append 'device-mapping- + (string->symbol (basename device)))) + '())) + + (with-monad %store-monad + (return (service + (provision (list (symbol-append 'swap- (string->symbol device)))) + (requirement `(udev ,@requirement)) + (documentation "Enable the given swap device.") (start #~(lambda () - #$command)) - (stop #~(const #f)) + (swapon #$device) + #t)) + (stop #~(lambda _ + (swapoff #$device) + #f)) (respawn? #f))))) (define %base-services diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 6a7d194659..d532fc8d99 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -25,6 +25,7 @@ #:use-module (guix gexp) #:use-module (guix monads) #:export (static-networking-service + dhcp-client-service tor-service)) ;;; Commentary: @@ -50,9 +51,15 @@ gateway." (with-monad %store-monad (return (service + + ;; Unless we're providing the loopback interface, wait for udev to be up + ;; and running so that INTERFACE is actually usable. + (requirement (if (memq 'loopback provision) + '() + '(udev))) + (documentation - (string-append "Set up networking on the '" interface - "' interface using a static IP address.")) + "Bring up the networking interface using a static IP address.") (provision provision) (start #~(lambda _ ;; Return #t if successfully started. @@ -88,6 +95,45 @@ gateway." #t))))) (respawn? #f))))) +(define* (dhcp-client-service #:key (dhcp isc-dhcp)) + "Return a service that runs @var{dhcp}, a Dynamic Host Configuration +Protocol (DHCP) client, on all the non-loopback network interfaces." + + (define dhclient + #~(string-append #$dhcp "/sbin/dhclient")) + + (define pid-file + "/var/run/dhclient.pid") + + (with-monad %store-monad + (return (service + (documentation "Set up networking via DHCP.") + (requirement '(user-processes udev)) + + ;; XXX: Running with '-nw' ("no wait") avoids blocking for a + ;; minute when networking is unavailable, but also means that the + ;; interface is not up yet when 'start' completes. To wait for + ;; the interface to be ready, one should instead monitor udev + ;; events. + (provision '(networking)) + + (start #~(lambda _ + ;; When invoked without any arguments, 'dhclient' + ;; discovers all non-loopback interfaces *that are + ;; up*. However, the relevant interfaces are + ;; typically down at this point. Thus we perform our + ;; own interface discovery here. + (let* ((valid? (negate loopback-network-interface?)) + (ifaces (filter valid? + (all-network-interfaces))) + (pid (fork+exec-command + (cons* #$dhclient "-nw" + "-pf" #$pid-file + ifaces)))) + (and (zero? (cdr (waitpid pid))) + (call-with-input-file #$pid-file read))))) + (stop #~(make-kill-destructor)))))) + (define* (tor-service #:key (tor tor)) "Return a service to run the @uref{https://torproject.org,Tor} daemon. diff --git a/gnu/system.scm b/gnu/system.scm index db7b7e7a2f..d15c864384 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -105,6 +105,8 @@ (mapped-devices operating-system-mapped-devices ; list of <mapped-device> (default '())) (file-systems operating-system-file-systems) ; list of fs + (swap-devices operating-system-swap-devices ; list of strings + (default '())) (users operating-system-users ; list of user accounts (default '())) @@ -160,13 +162,24 @@ file." ;;; Services. ;;; -(define (luks-device-mapping source target) +(define (open-luks-device source target) "Return a gexp that maps SOURCE to TARGET as a LUKS device, using 'cryptsetup'." #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") "open" "--type" "luks" #$source #$target))) +(define (close-luks-device source target) + "Return a gexp that closes TARGET, a LUKS device." + #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") + "close" #$target))) + +(define luks-device-mapping + ;; The type of LUKS mapped devices. + (mapped-device-kind + (open open-luks-device) + (close close-luks-device))) + (define (other-file-system-services os) "Return file system services for the file systems of OS that are not marked as 'needed-for-boot'." @@ -203,16 +216,52 @@ as 'needed-for-boot'." #:flags flags)))) file-systems))) +(define (mapped-device-user device file-systems) + "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f." + (let ((target (string-append "/dev/mapper/" (mapped-device-target device)))) + (find (lambda (fs) + (string=? (file-system-device fs) target)) + file-systems))) + +(define (operating-system-user-mapped-devices os) + "Return the subset of mapped devices that can be installed in +user-land--i.e., those not needed during boot." + (let ((devices (operating-system-mapped-devices os)) + (file-systems (operating-system-file-systems os))) + (filter (lambda (md) + (let ((user (mapped-device-user md file-systems))) + (or (not user) + (not (file-system-needed-for-boot? user))))) + devices))) + +(define (operating-system-boot-mapped-devices os) + "Return the subset of mapped devices that must be installed during boot, +from the initrd." + (let ((devices (operating-system-mapped-devices os)) + (file-systems (operating-system-file-systems os))) + (filter (lambda (md) + (let ((user (mapped-device-user md file-systems))) + (and user (file-system-needed-for-boot? user)))) + devices))) + (define (device-mapping-services os) "Return the list of device-mapping services for OS as a monadic list." (sequence %store-monad (map (lambda (md) - (let ((source (mapped-device-source md)) - (target (mapped-device-target md)) - (command (mapped-device-command md))) + (let* ((source (mapped-device-source md)) + (target (mapped-device-target md)) + (type (mapped-device-type md)) + (open (mapped-device-kind-open type)) + (close (mapped-device-kind-close type))) (device-mapping-service target - (command source target)))) - (operating-system-mapped-devices os)))) + (open source target) + (close source target)))) + (operating-system-user-mapped-devices os)))) + +(define (swap-services os) + "Return the list of swap services for OS as a monadic list." + (sequence %store-monad + (map swap-service (operating-system-swap-devices os)))) (define (essential-services os) "Return the list of essential services for OS. These are special services @@ -221,13 +270,14 @@ bookkeeping." (mlet* %store-monad ((mappings (device-mapping-services os)) (root-fs (root-file-system-service)) (other-fs (other-file-system-services os)) + (swaps (swap-services os)) (procs (user-processes-service (map (compose first service-provision) other-fs))) (host-name (host-name-service (operating-system-host-name os)))) (return (cons* host-name procs root-fs - (append other-fs mappings))))) + (append other-fs mappings swaps))))) (define (operating-system-services os) "Return all the services of OS, including \"internal\" services that do not @@ -539,10 +589,14 @@ we're running in the final root." boot?)) (operating-system-file-systems os))) - ;; TODO: Pass the mapped devices required by boot-time file systems to the - ;; initrd. - (mlet %store-monad - ((initrd ((operating-system-initrd os) boot-file-systems))) + (define mapped-devices + (operating-system-boot-mapped-devices os)) + + (define make-initrd + (operating-system-initrd os)) + + (mlet %store-monad ((initrd (make-initrd boot-file-systems + #:mapped-devices mapped-devices))) (return #~(string-append #$initrd "/initrd")))) (define (kernel->grub-label kernel) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 90e2b0c796..ed9d70587f 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu system file-systems) + #:use-module (guix gexp) #:use-module (guix records) #:export (<file-system> file-system @@ -43,7 +44,12 @@ mapped-device? mapped-device-source mapped-device-target - mapped-device-command)) + mapped-device-type + + mapped-device-kind + mapped-device-kind? + mapped-device-kind-open + mapped-device-kind-close)) ;;; Commentary: ;;; @@ -145,6 +151,13 @@ mapped-device? (source mapped-device-source) ;string (target mapped-device-target) ;string - (command mapped-device-command)) ;source target -> gexp + (type mapped-device-type)) ;<mapped-device-kind> + +(define-record-type* <mapped-device-type> mapped-device-kind + make-mapped-device-kind + mapped-device-kind? + (open mapped-device-kind-open) ;source target -> gexp + (close mapped-device-kind-close ;source target -> gexp + (default (const #~(const #f))))) ;;; file-systems.scm ends here diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 93f751b757..d1b1216f9d 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -126,15 +126,16 @@ initrd code." (define* (base-initrd file-systems #:key + (mapped-devices '()) qemu-networking? virtio? volatile-root? - (extra-modules '()) - guile-modules-in-chroot?) - ;; TODO: Support boot-time device mappings. + (extra-modules '())) "Return a monadic derivation that builds a generic initrd. FILE-SYSTEMS is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified on the kernel command line via '--root'. +MAPPED-DEVICES is a list of device mappings to realize before FILE-SYSTEMS are +mounted. When QEMU-NETWORKING? is true, set up networking with the standard QEMU parameters. When VIRTIO? is true, load additional modules so the initrd can @@ -146,12 +147,7 @@ to it are lost. The initrd is automatically populated with all the kernel modules necessary for FILE-SYSTEMS and for the given options. However, additional kernel modules can be listed in EXTRA-MODULES. They will be added to the initrd, and -loaded at boot time in the order in which they appear. - -When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in -the new root. This is necessary is the file specified as '--load' needs -access to these modules (which is the case if it wants to even just print an -exception and backtrace!)." +loaded at boot time in the order in which they appear." (define virtio-modules ;; Modules for Linux para-virtualized devices, for use in QEMU guests. '("virtio.ko" "virtio_ring.ko" "virtio_pci.ko" @@ -197,6 +193,16 @@ exception and backtrace!)." (list unionfs-fuse/static) '()))) + (define device-mapping-commands + ;; List of gexps to open the mapped devices. + (map (lambda (md) + (let* ((source (mapped-device-source md)) + (target (mapped-device-target md)) + (type (mapped-device-type md)) + (open (mapped-device-kind-open type))) + (open source target))) + mapped-devices)) + (mlet %store-monad ((kodir (flat-linux-module-directory linux-libre linux-modules))) (expression->initrd @@ -211,11 +217,12 @@ exception and backtrace!)." '#$helper-packages))) (boot-system #:mounts '#$(map file-system->spec file-systems) + #:pre-mount (lambda () + (and #$@device-mapping-commands)) #:linux-modules (map (lambda (file) (string-append #$kodir "/" file)) '#$linux-modules) #:qemu-guest-networking? #$qemu-networking? - #:guile-modules-in-chroot? '#$guile-modules-in-chroot? #:volatile-root? '#$volatile-root?)) #:name "base-initrd" #:modules '((guix build utils) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 5d638398d1..6970021e1f 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -95,6 +95,7 @@ (system-group (name "tty") (id %tty-gid)) (system-group (name "dialout")) (system-group (name "kmem")) + (system-group (name "input")) ; input devices, from udev (system-group (name "video")) (system-group (name "audio")) (system-group (name "netdev")) ; used in avahi-dbus.conf @@ -102,7 +103,8 @@ (system-group (name "disk")) (system-group (name "floppy")) (system-group (name "cdrom")) - (system-group (name "tape"))))) + (system-group (name "tape")) + (system-group (name "kvm"))))) ; for /dev/kvm (define (default-skeletons) "Return the default skeleton files for /etc/skel. These files are copied by diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 4ee8dc5cf2..799ab51d41 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -159,8 +159,7 @@ made available under the /xchg CIFS share." (return initrd) (base-initrd %linux-vm-file-systems #:virtio? #t - #:qemu-networking? #t - #:guile-modules-in-chroot? #t)))) + #:qemu-networking? #t)))) (define builder ;; Code that launches the VM that evaluates EXP. @@ -290,9 +289,11 @@ to USB sticks meant to be read-only." ;; Since this is meant to be used on real hardware, don't ;; install QEMU networking or anything like that, but make sure ;; USB mass storage devices are available. - (initrd (cut base-initrd <> - #:volatile-root? #t - #:extra-modules '("usb-storage.ko"))) + (initrd (lambda (file-systems . rest) + (apply base-initrd file-systems + #:volatile-root? #t + #:extra-modules '("usb-storage.ko") + rest))) ;; Force our own root file system. (file-systems (cons (file-system @@ -334,9 +335,11 @@ of the GNU system as described by OS." (let ((os (operating-system (inherit os) ;; Use an initrd with the whole QEMU shebang. - (initrd (cut base-initrd <> - #:virtio? #t - #:qemu-networking? #t)) + (initrd (lambda (file-systems . rest) + (apply base-initrd file-systems + #:virtio? #t + #:qemu-networking? #t + rest))) ;; Force our own root file system. (file-systems (cons (file-system @@ -359,10 +362,12 @@ of the GNU system as described by OS." "Return an operating system based on OS suitable for use in a virtualized environment with the store shared with the host." (operating-system (inherit os) - (initrd (cut base-initrd <> - #:volatile-root? #t - #:virtio? #t - #:qemu-networking? #t)) + (initrd (lambda (file-systems . rest) + (apply base-initrd file-systems + #:volatile-root? #t + #:virtio? #t + #:qemu-networking? #t + rest))) (file-systems (cons* (file-system (mount-point "/") (device "/dev/vda1") diff --git a/guix/build/download.scm b/guix/build/download.scm index d98933a907..c081f3b29b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -112,13 +112,25 @@ abbreviation of URI showing the scheme, host, and basename of the file." "Hold a weak reference from FROM to TO." (hashq-set! table from to)))) -(define (tls-wrap port) - "Return PORT wrapped in a TLS connection." +(define (tls-wrap port server) + "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS +host name without trailing dot." (define (log level str) (format (current-error-port) "gnutls: [~a|~a] ~a" (getpid) level str)) (let ((session (make-session connection-end/client))) + + ;; Some servers such as 'cloud.github.com' require the client to support + ;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is + ;; not available in older GnuTLS releases. See + ;; <http://bugs.gnu.org/18526> for details. + (if (module-defined? (resolve-interface '(gnutls)) + 'set-session-server-name!) + (set-session-server-name! session server-name-type/dns server) + (format (current-error-port) + "warning: TLS 'SERVER NAME' extension not supported~%")) + (set-session-transport-fd! session (fileno port)) (set-session-default-priority! session) (set-session-credentials! session (make-certificate-credentials)) @@ -169,7 +181,7 @@ which is not available during bootstrap." (setvbuf s _IOFBF) (if (eq? 'https (uri-scheme uri)) - (tls-wrap s) + (tls-wrap s (uri-host uri)) s)) (lambda args ;; Connection failed, so try one of the other addresses. diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 7a1bad7331..7e5245fcc6 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -21,6 +21,7 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 ftw) #:export (errno @@ -30,7 +31,17 @@ MS_MOVE mount umount - processes)) + swapon + swapoff + processes + + IFF_UP + IFF_BROADCAST + IFF_LOOPBACK + all-network-interfaces + network-interfaces + network-interface-flags + loopback-network-interface?)) ;;; Commentary: ;;; @@ -155,6 +166,30 @@ constants from <sys/mount.h>." (when update-mtab? (remove-from-mtab target)))))) +(define swapon + (let* ((ptr (dynamic-func "swapon" (dynamic-link))) + (proc (pointer->procedure int ptr (list '* int)))) + (lambda* (device #:optional (flags 0)) + "Use the block special device at DEVICE for swapping." + (let ((ret (proc (string->pointer device) flags)) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "swapon" "~S: ~A" + (list device (strerror err)) + (list err))))))) + +(define swapoff + (let* ((ptr (dynamic-func "swapoff" (dynamic-link))) + (proc (pointer->procedure int ptr '(*)))) + (lambda (device) + "Stop using block special device DEVICE for swapping." + (let ((ret (proc (string->pointer device))) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "swapff" "~S: ~A" + (list device (strerror err)) + (list err))))))) + (define (kernel? pid) "Return #t if PID designates a \"kernel thread\" rather than a normal user-land process." @@ -180,4 +215,130 @@ user-land process." (scandir "/proc")) <)) + +;;; +;;; Network interfaces. +;;; + +(define SIOCGIFCONF ;from <bits/ioctls.h> + (if (string-contains %host-type "linux") + #x8912 ;GNU/Linux + #xf00801a4)) ;GNU/Hurd +(define SIOCGIFFLAGS + (if (string-contains %host-type "linux") + #x8913 ;GNU/Linux + #xc4804191)) ;GNU/Hurd + +;; Flags and constants from <net/if.h>. + +(define IFF_UP #x1) ;Interface is up +(define IFF_BROADCAST #x2) ;Broadcast address valid. +(define IFF_LOOPBACK #x8) ;Is a loopback net. + +(define IF_NAMESIZE 16) ;maximum interface name size + +(define ifconf-struct + ;; 'struct ifconf', from <net/if.h>. + (list int ;int ifc_len + '*)) ;struct ifreq *ifc_ifcu + +(define ifreq-struct-size + ;; 'struct ifreq' begins with an array of IF_NAMESIZE bytes containing the + ;; interface name (nul-terminated), followed by a bunch of stuff. This is + ;; its size in bytes. + (if (= 8 (sizeof '*)) + 40 + 32)) + +(define %ioctl + ;; The most terrible interface, live from Scheme. + (pointer->procedure int + (dynamic-func "ioctl" (dynamic-link)) + (list int unsigned-long '*))) + +(define (bytevector->string-list bv stride len) + "Return the null-terminated strings found in BV every STRIDE bytes. Read at +most LEN bytes from BV." + (let loop ((bytes (take (bytevector->u8-list bv) + (min len (bytevector-length bv)))) + (result '())) + (match bytes + (() + (reverse result)) + (_ + (loop (drop bytes stride) + (cons (list->string (map integer->char + (take-while (negate zero?) bytes))) + result)))))) + +(define* (network-interfaces #:optional sock) + "Return the list of existing network interfaces. This is typically limited +to interfaces that are currently up." + (let* ((close? (not sock)) + (sock (or sock (socket SOCK_STREAM AF_INET 0))) + (len (* ifreq-struct-size 10)) + (reqs (make-bytevector len)) + (conf (make-c-struct ifconf-struct + (list len (bytevector->pointer reqs)))) + (ret (%ioctl (fileno sock) SIOCGIFCONF conf)) + (err (errno))) + (when close? + (close-port sock)) + (if (zero? ret) + (bytevector->string-list reqs ifreq-struct-size + (match (parse-c-struct conf ifconf-struct) + ((len . _) len))) + (throw 'system-error "network-interface-list" + "network-interface-list: ~A" + (list (strerror err)) + (list err))))) + +(define %interface-line + ;; Regexp matching an interface line in Linux's /proc/net/dev. + (make-regexp "^[[:blank:]]*([[:alnum:]]+):.*$")) + +(define (all-network-interfaces) + "Return all the registered network interfaces, including those that are not +up." + (call-with-input-file "/proc/net/dev" ;XXX: Linux-specific + (lambda (port) + (let loop ((interfaces '())) + (let ((line (read-line port))) + (cond ((eof-object? line) + (reverse interfaces)) + ((regexp-exec %interface-line line) + => + (lambda (match) + (loop (cons (match:substring match 1) interfaces)))) + (else + (loop interfaces)))))))) + +(define (network-interface-flags socket name) + "Return a number that is the bit-wise or of 'IFF*' flags for network +interface NAME." + (let ((req (make-bytevector ifreq-struct-size))) + (bytevector-copy! (string->utf8 name) 0 req 0 + (min (string-length name) (- IF_NAMESIZE 1))) + (let* ((ret (%ioctl (fileno socket) SIOCGIFFLAGS + (bytevector->pointer req))) + (err (errno))) + (if (zero? ret) + + ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of + ;; 'struct ifreq', and it's a short int. + (bytevector-sint-ref req IF_NAMESIZE (native-endianness) + (sizeof short)) + + (throw 'system-error "network-interface-flags" + "network-interface-flags on ~A: ~A" + (list name (strerror err)) + (list err)))))) + +(define (loopback-network-interface? name) + "Return true if NAME designates a loopback network interface." + (let* ((sock (socket SOCK_STREAM AF_INET 0)) + (flags (network-interface-flags sock name))) + (close-port sock) + (not (zero? (logand flags IFF_LOOPBACK))))) + ;;; syscalls.scm ends here diff --git a/guix/profiles.scm b/guix/profiles.scm index aa88b849e1..18733a6664 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -70,6 +70,7 @@ profile-derivation generation-number generation-numbers + profile-generations previous-generation-number generation-time generation-file-name)) @@ -561,6 +562,13 @@ former profiles were found." profiles) <)))) +(define (profile-generations profile) + "Return a list of PROFILE's generations." + (let ((generations (generation-numbers profile))) + (if (equal? generations '(0)) + '() + generations))) + (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 diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index b3b502425c..391906ff79 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -534,10 +534,6 @@ success, #f otherwise." (build-requirements-features requirements) (build-machine-features machine)))) -(define (machine-faster? m1 m2) - "Return #t if M1 is faster than M2." - (> (build-machine-speed m1) (build-machine-speed m2))) - (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." @@ -558,14 +554,16 @@ allowed on MACHINE." (_ +inf.0))))) ;something's fishy about MACHINE, so avoid it -(define (machine-less-loaded? m1 m2) - "Return #t if the load on M1 is lower than that on M2." - (< (machine-load m1) (machine-load m2))) +(define (machine-power-factor m) + "Return a factor that aggregates the speed and load of M. The higher the +better." + (/ (build-machine-speed m) + (+ 1 (machine-load m)))) (define (machine-less-loaded-or-faster? m1 m2) - "Return #t if M1 is either less loaded or faster than M2." - (or (machine-less-loaded? m1 m2) - (machine-faster? m1 m2))) + "Return #t if M1 is either less loaded or faster than M2. (This relation +defines a total order on machines.)" + (> (machine-power-factor m1) (machine-power-factor m2))) (define (machine-lock-file machine hint) "Return the name of MACHINE's lock file for HINT." @@ -610,22 +608,25 @@ allowed on MACHINE." (list machine1 slot1) (list machine2 slot2)))))))) - (let ((machines+slots (sort machines+slots - (undecorate machine-less-loaded-or-faster?)))) + (let loop ((machines+slots + (sort machines+slots + (undecorate machine-less-loaded-or-faster?)))) (match machines+slots - (((best slot) (others slots) ...) - ;; Release slots from the uninteresting machines. - (for-each release-build-slot slots) - + (((best slot) others ...) ;; Return the best machine unless it's already overloaded. (if (< (machine-load best) 2.) + (match others + (((machines slots) ...) + ;; Release slots from the uninteresting machines. + (for-each release-build-slot slots) + + ;; Prevent SLOT from being GC'd. + (set! %slots (cons slot %slots)) + best)) (begin - ;; Prevent SLOT from being GC'd. - (set! %slots (cons slot %slots)) - best) - (begin + ;; BEST is overloaded, so try the next one. (release-build-slot slot) - #f))) + (loop others)))) (() #f))))) (define* (process-request wants-local? system drv features diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 95c0130c95..7cd95167d2 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -716,12 +716,9 @@ more information.~%")) (leave (_ "profile '~a' does not exist~%") profile)) ((string-null? pattern) - (let ((numbers (generation-numbers profile))) - (if (equal? numbers '(0)) - (exit 0) - (for-each display-and-delete - (delete current-generation-number - numbers))))) + (for-each display-and-delete + (delete current-generation-number + (profile-generations profile)))) ;; Do not delete the zeroth generation. ((equal? 0 (string->number pattern)) (exit 0)) @@ -828,11 +825,7 @@ more information.~%")) (leave (_ "profile '~a' does not exist~%") profile)) ((string-null? pattern) - (let ((numbers (generation-numbers profile))) - (leave-on-EPIPE - (if (equal? numbers '(0)) - (exit 0) - (for-each list-generation numbers))))) + (for-each list-generation (profile-generations profile))) ((matching-generations pattern profile) => (lambda (numbers) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 5dafb84f91..c2ea0e3d97 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -23,6 +23,8 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix download) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) @@ -38,34 +40,27 @@ "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" ) -(define* (unpack store tarball #:key verbose?) +(define* (unpack tarball #:key verbose?) "Return a derivation that unpacks TARBALL into STORE and compiles Scheme files." (define builder - `(begin - (use-modules (guix build pull)) + #~(begin + (use-modules (guix build pull)) - (build-guix (assoc-ref %outputs "out") - (assoc-ref %build-inputs "tarball") + (build-guix #$output #$tarball - ;; XXX: This is not perfect, enabling VERBOSE? means - ;; building a different derivation. - #:debug-port (if ',verbose? - (current-error-port) - (%make-void-port "w")) - #:tar (assoc-ref %build-inputs "tar") - #:gzip (assoc-ref %build-inputs "gzip") - #:gcrypt (assoc-ref %build-inputs "gcrypt")))) + ;; XXX: This is not perfect, enabling VERBOSE? means + ;; building a different derivation. + #:debug-port (if #$verbose? + (current-error-port) + (%make-void-port "w")) + #:tar #$tar + #:gzip #$gzip + #:gcrypt #$libgcrypt))) - (build-expression->derivation store "guix-latest" builder - #:inputs - `(("tar" ,(package-derivation store tar)) - ("gzip" ,(package-derivation store gzip)) - ("gcrypt" ,(package-derivation store - libgcrypt)) - ("tarball" ,tarball)) - #:modules '((guix build pull) - (guix build utils)))) + (gexp->derivation "guix-latest" builder + #:modules '((guix build pull) + (guix build utils)))) ;;; @@ -114,6 +109,33 @@ Download and deploy the latest version of Guix.\n")) (lambda args (show-version-and-exit "guix pull"))))) +(define what-to-build + (store-lift show-what-to-build)) +(define indirect-root-added + (store-lift add-indirect-root)) + +(define* (build-and-install tarball config-dir + #:key verbose?) + "Build the tool from TARBALL, and install it in CONFIG-DIR." + (mlet* %store-monad ((source (unpack tarball #:verbose? verbose?)) + (source-dir -> (derivation->output-path source)) + (to-do? (what-to-build (list source)))) + (if to-do? + (mlet* %store-monad ((built? (built-derivations (list source)))) + (if built? + (mlet* %store-monad + ((latest -> (string-append config-dir "/latest")) + (done (indirect-root-added latest))) + (switch-symlinks latest source-dir) + (format #t + (_ "updated ~a successfully deployed under `~a'~%") + %guix-package-name latest) + (return #t)) + (leave (_ "failed to update Guix, check the build log~%")))) + (begin + (display (_ "Guix already up to date\n")) + (return #t))))) + (define (guix-pull . args) (define (parse-options) ;; Return the alist of option values. @@ -136,20 +158,6 @@ Download and deploy the latest version of Guix.\n")) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile (canonical-package guile-2.0))))) - (let* ((config-dir (config-directory)) - (source (unpack store tarball - #:verbose? (assoc-ref opts 'verbose?))) - (source-dir (derivation->output-path source))) - (if (show-what-to-build store (list source)) - (if (build-derivations store (list source)) - (let ((latest (string-append config-dir "/latest"))) - (add-indirect-root store latest) - (switch-symlinks latest source-dir) - (format #t - (_ "updated ~a successfully deployed under `~a'~%") - %guix-package-name latest) - #t) - (leave (_ "failed to update Guix, check the build log~%"))) - (begin - (display (_ "Guix already up to date\n")) - #t)))))))) + (run-with-store store + (build-and-install tarball (config-directory) + #:verbose? (assoc-ref opts 'verbose?)))))))) diff --git a/guix/ui.scm b/guix/ui.scm index f11c2e9c92..531d922ad9 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -25,6 +25,7 @@ #:use-module (guix packages) #:use-module (guix build-system) #:use-module (guix derivations) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix licenses) #:select (license? license-name)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -370,15 +371,13 @@ exists. Honor the XDG specs, (cut string-append <> "/guix")))) (catch 'system-error (lambda () - (mkdir dir) + (mkdir-p dir) dir) (lambda args - (match (system-error-errno args) - ((or EEXIST 0) - dir) - (err - (leave (_ "failed to create configuration directory `~a': ~a~%") - dir (strerror err)))))))) + (let ((err (system-error-errno args))) + ;; ERR is necessarily different from EEXIST. + (leave (_ "failed to create configuration directory `~a': ~a~%") + dir (strerror err))))))) (define* (fill-paragraph str width #:optional (column 0)) "Fill STR such that each line contains at most WIDTH characters, assuming diff --git a/guix/utils.scm b/guix/utils.scm index b61ff2477d..34a5e6c971 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -600,8 +600,9 @@ REPLACEMENT." "Call PROC with a name of a temporary file and open output port to that file; close the file and delete it when leaving the dynamic extent of this call." - (let* ((template (string-copy "guix-file.XXXXXX")) - (out (mkstemp! template))) + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/guix-file.XXXXXX")) + (out (mkstemp! template))) (dynamic-wind (lambda () #t) diff --git a/test-env.in b/test-env.in index 9d0c8cc414..34f57257d2 100644 --- a/test-env.in +++ b/test-env.in @@ -87,6 +87,12 @@ then trap "kill $daemon_pid ; rm -rf $NIX_STATE_DIR" EXIT fi +# Avoid issues that could stem from l10n, such as language/encoding +# mismatches. +unset LANGUAGE +LC_MESSAGES=C +export LC_MESSAGES + storedir="@storedir@" prefix="@prefix@" datarootdir="@datarootdir@" diff --git a/tests/syscalls.scm b/tests/syscalls.scm index ab34fc825b..51846d3c36 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -18,7 +18,9 @@ (define-module (test-syscalls) #:use-module (guix build syscalls) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) ;; Test the (guix build syscalls) module, although there's not much that can ;; actually be tested without being root. @@ -42,6 +44,49 @@ ;; Both return values have been encountered in the wild. (memv (system-error-errno args) (list EPERM ENOENT))))) +(test-assert "swapon, ENOENT/EPERM" + (catch 'system-error + (lambda () + (swapon "/does-not-exist") + #f) + (lambda args + (memv (system-error-errno args) (list EPERM ENOENT))))) + +(test-assert "swapoff, EINVAL/EPERM" + (catch 'system-error + (lambda () + (swapoff "/does-not-exist") + #f) + (lambda args + (memv (system-error-errno args) (list EPERM EINVAL))))) + +(test-assert "all-network-interfaces" + (match (all-network-interfaces) + (((? string? names) ..1) + (member "lo" names)))) + +(test-assert "network-interfaces" + (match (network-interfaces) + (((? string? names) ..1) + (lset<= string=? names (all-network-interfaces))))) + +(test-assert "network-interface-flags" + (let* ((sock (socket SOCK_STREAM AF_INET 0)) + (flags (network-interface-flags sock "lo"))) + (close-port sock) + (and (not (zero? (logand flags IFF_LOOPBACK))) + (not (zero? (logand flags IFF_UP)))))) + +(test-equal "loopback-network-interface?" + ENODEV + (and (loopback-network-interface? "lo") + (catch 'system-error + (lambda () + (loopback-network-interface? "nonexistent") + #f) + (lambda args + (system-error-errno args))))) + (test-end) |