From 66ef5411471e8d5f25815b9ab1f360ad56e08544 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 00:17:43 +0200 Subject: offload: Better synchronize with remote invocation of 'guix archive --missing'. * guix/scripts/offload.scm (send-files)[missing-files]: Call 'waitpid' after reading all of MISSING. --- guix/scripts/offload.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index c5cae4b07a..e340b7e8cc 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -443,9 +443,11 @@ success, #f otherwise." "-i" (build-machine-private-key machine) (build-machine-name machine) "guix" "archive" "--missing") - (open-input-string files)))) + (open-input-string files))) + ((result) + (get-string-all missing))) (for-each waitpid pids) - (string-tokenize (get-string-all missing)))) + (string-tokenize result))) (with-store store (guard (c ((nix-protocol-error? c) -- cgit v1.2.3 From 30ce8012cd6265b12f756283633be94a547bf990 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 00:24:24 +0200 Subject: offload: '{send,receive}-files' wait for completion of the transfer. Fixes situations where the remote 'guix build' is invoked before the .drv has been completely copied, as reported at . In some cases 'send-files' would return before the other end is done importing the files, and so the subsequent 'guix build' invocation would just miss the .drv file it refers to. * guix/utils.scm (call-with-decompressed-port): Don't close PORT. (call-with-compressed-output-port): Likewise. * tests/utils.scm ("compressed-output-port + decompressed-port"): Adjust accordingly. * guix/scripts/offload.scm (send-files): Add explicit (close-pipe pipe) call. (retrieve-files): Likewise. --- guix/scripts/offload.scm | 7 +++++-- guix/utils.scm | 8 ++------ tests/utils.scm | 6 ++++-- 3 files changed, 11 insertions(+), 10 deletions(-) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index e340b7e8cc..d87cad3f23 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -474,7 +474,9 @@ success, #f otherwise." (warning (_ "failed while exporting files to '~a': ~a~%") (build-machine-name machine) (strerror (system-error-errno args))))))) - #t)))) + + ;; Wait for the 'lsh' process to complete. + (zero? (close-pipe pipe)))))) (define (retrieve-files files machine) "Retrieve FILES from MACHINE's store, and import them." @@ -502,7 +504,8 @@ success, #f otherwise." #:log-port (current-error-port) #:lock? #f))) - #t))))) + ;; Wait for the 'lsh' process to complete. + (zero? (close-pipe pipe))))))) ;;; diff --git a/guix/utils.scm b/guix/utils.scm index 84cb5ae983..53fc68d27b 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -229,14 +229,12 @@ a symbol such as 'xz." (define (call-with-decompressed-port compression port proc) "Call PROC with a wrapper around PORT, a file port, that decompresses data -read from PORT according to COMPRESSION, a symbol such as 'xz. PORT is closed -as soon as PROC's dynamic extent is entered." +read from PORT according to COMPRESSION, a symbol such as 'xz." (let-values (((decompressed pids) (decompressed-port compression port))) (dynamic-wind (const #f) (lambda () - (close-port port) (proc decompressed)) (lambda () (close-port decompressed) @@ -286,14 +284,12 @@ of PIDs to wait for." (define (call-with-compressed-output-port compression port proc) "Call PROC with a wrapper around PORT, a file port, that compresses data -that goes to PORT according to COMPRESSION, a symbol such as 'xz. PORT is -closed as soon as PROC's dynamic extent is entered." +that goes to PORT according to COMPRESSION, a symbol such as 'xz." (let-values (((compressed pids) (compressed-output-port compression port))) (dynamic-wind (const #f) (lambda () - (close-port port) (proc compressed)) (lambda () (close-port compressed) diff --git a/tests/utils.scm b/tests/utils.scm index 4d2d123c6b..8ad399f75c 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -164,10 +164,12 @@ (false-if-exception (delete-file temp-file)) (test-assert "compressed-output-port + decompressed-port" (let* ((file (search-path %load-path "guix/derivations.scm")) - (data (call-with-input-file file get-bytevector-all))) - (call-with-compressed-output-port 'xz (open-file temp-file "w0b") + (data (call-with-input-file file get-bytevector-all)) + (port (open-file temp-file "w0b"))) + (call-with-compressed-output-port 'xz port (lambda (compressed) (put-bytevector compressed data))) + (close-port port) (bytevector=? data (call-with-decompressed-port 'xz (open-file temp-file "r0b") -- cgit v1.2.3 From dcd3ed9cc764d269259374286807a5483ad219b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 13:55:59 +0200 Subject: gnu: man-pages: Fix URL. * gnu/packages/man.scm (man-pages): Use the 'kernel.org' mirror set. --- gnu/packages/man.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnu/packages/man.scm b/gnu/packages/man.scm index a6c2c1c0a8..2e0b161578 100644 --- a/gnu/packages/man.scm +++ b/gnu/packages/man.scm @@ -117,7 +117,7 @@ the traditional flat-text whatis databases.") (source (origin (method url-fetch) (uri (string-append - "mirror://kernel/linux/docs/man-pages/man-pages-" + "mirror://kernel.org/linux/docs/man-pages/man-pages-" version ".tar.xz")) (sha256 (base32 -- cgit v1.2.3 From 0b7a0c2030fe85fc54f428e1d874017d4072eead Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 23:47:15 +0200 Subject: gnu: unionfs-fuse-static: Remove dependency on util-linux. * gnu/packages/linux.scm (fuse-static): New variable. (unionfs-fuse/static): Use it. --- gnu/packages/linux.scm | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index da5b31a169..759b92d51e 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -962,6 +962,23 @@ space, using the FUSE library. Mounting a union file system allows you to UnionFS-FUSE additionally supports copy-on-write.") (license bsd-3))) +(define fuse-static + (package (inherit fuse) + (name "fuse-static") + (source (origin (inherit (package-source fuse)) + (modules '((guix build utils))) + (snippet + ;; Normally libfuse invokes mount(8) so that /etc/mtab is + ;; updated. Change calls to 'mtab_needs_update' to 0 so that + ;; it doesn't do that, allowing us to remove the dependency on + ;; util-linux (something that is useful in initrds.) + '(substitute* '("lib/mount_util.c" + "util/mount_util.c") + (("mtab_needs_update[[:blank:]]*\\([a-z_]+\\)") + "0") + (("/bin/") + ""))))))) + (define-public unionfs-fuse/static (package (inherit unionfs-fuse) (synopsis "User-space union file system (statically linked)") @@ -976,4 +993,5 @@ UnionFS-FUSE additionally supports copy-on-write.") libs " dl)")))))) (arguments '(#:tests? #f - #:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static"))))) + #:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static"))) + (inputs `(("fuse" ,fuse-static))))) -- cgit v1.2.3 From 1c96c1bbabb9646aba2a3860cac02157f56c4dd1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 23:59:08 +0200 Subject: linux-initrd: Mount / as a unionfs when asking for a volatile root. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make /dev/fuse. (boot-system): Add #:unionfs parameter. Invoke UNIONFS instead of copying files over when VOLATILE-ROOT? is true. * gnu/system/linux-initrd.scm (expression->initrd): Add #:inputs parameter. [files-to-copy]: New procedure. [builder]: Add 'to-copy' parameter; honor it. (qemu-initrd)[linux-modules]: Add 'fuse.ko' when VOLATILE-ROOT?. Pass UNIONFS-FUSE/STATIC as #:inputs; change builder to pass #:unionfs to 'boot-system'. --- gnu/system/linux-initrd.scm | 75 +++++++++++++++++++++++++++++++++------------ guix/build/linux-initrd.scm | 38 ++++++++++------------- 2 files changed, 73 insertions(+), 40 deletions(-) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 42ca29cb58..786e068764 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -21,12 +21,15 @@ #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix)) + #:use-module ((guix derivations) + #:select (derivation->output-path)) #:use-module (gnu packages cpio) #:use-module (gnu packages compression) #:use-module (gnu packages linux) #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) + #:use-module (ice-9 match) #:use-module (ice-9 regex) #:export (expression->initrd qemu-initrd @@ -49,12 +52,14 @@ (name "guile-initrd") (system (%current-system)) (modules '()) + (inputs '()) (linux #f) (linux-modules '())) "Return a package that contains a Linux initrd (a gzipped cpio archive) containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list -of `.ko' file names to be copied from LINUX into the initrd. MODULES is a -list of Guile module names to be embedded in the initrd." +of `.ko' file names to be copied from LINUX into the initrd. INPUTS is a list +of additional inputs to be copied in the initrd. MODULES is a list of Guile +module names to be embedded in the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. @@ -63,7 +68,16 @@ list of Guile module names to be embedded in the initrd." ;; Return a regexp that matches STR exactly. (string-append "^" (regexp-quote str) "$")) - (define builder + (define (files-to-copy) + (mlet %store-monad ((inputs (lower-inputs inputs))) + (return (map (match-lambda + ((_ drv) + (derivation->output-path drv)) + ((_ drv sub-drv) + (derivation->output-path drv sub-drv))) + inputs)))) + + (define (builder to-copy) `(begin (use-modules (guix build utils) (ice-9 pretty-print) @@ -137,6 +151,18 @@ list of Guile module names to be embedded in the initrd." ,module module-dir)))) linux-modules)) + ,@(if (null? to-copy) + '() + `((let ((store ,(string-append "." (%store-prefix)))) + (mkdir-p store) + ;; XXX: Should we do export-references-graph? + (for-each (lambda (input) + (let ((target + (string-append store "/" + (basename input)))) + (copy-recursively input target))) + ',to-copy)))) + ;; Reset the timestamps of all the files that will make it in the ;; initrd. (for-each (cut utime <> 0 0 0 0) @@ -184,8 +210,10 @@ list of Guile module names to be embedded in the initrd." ("modules/compiled" ,compiled) ,@(if linux `(("linux" ,linux)) - '()))))) - (derivation-expression name builder + '()) + ,@inputs))) + (to-copy (files-to-copy))) + (derivation-expression name (builder to-copy) #:modules '((guix build utils)) #:inputs inputs))) @@ -224,22 +252,31 @@ to it are lost." '()) ,@(if (assoc-ref mounts '9p) virtio-9p-modules + '()) + ,@(if volatile-root? + '("fuse.ko") '()))) - (expression->initrd - `(begin - (use-modules (guix build linux-initrd)) - - (boot-system #:mounts ',mounts - #:linux-modules ',linux-modules - #:qemu-guest-networking? #t - #:guile-modules-in-chroot? ',guile-modules-in-chroot? - #:volatile-root? ',volatile-root?)) - #:name "qemu-initrd" - #:modules '((guix build utils) - (guix build linux-initrd)) - #:linux linux-libre - #:linux-modules linux-modules)) + (mlet %store-monad + ((unionfs (package-file unionfs-fuse/static "bin/unionfs"))) + (expression->initrd + `(begin + (use-modules (guix build linux-initrd)) + + (boot-system #:mounts ',mounts + #:linux-modules ',linux-modules + #:qemu-guest-networking? #t + #:guile-modules-in-chroot? ',guile-modules-in-chroot? + #:unionfs ,unionfs + #:volatile-root? ',volatile-root?)) + #:name "qemu-initrd" + #:modules '((guix build utils) + (guix build linux-initrd)) + #:linux linux-libre + #:linux-modules linux-modules + #:inputs (if volatile-root? + `(("unionfs" ,unionfs-fuse/static)) + '())))) (define (gnu-system-initrd) "Initrd for the GNU system itself, with nothing QEMU-specific." diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 61d4304b65..5d4446e720 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -143,7 +143,10 @@ (symlink "/proc/self/fd" (scope "dev/fd")) (symlink "/proc/self/fd/0" (scope "dev/stdin")) (symlink "/proc/self/fd/1" (scope "dev/stdout")) - (symlink "/proc/self/fd/2" (scope "dev/stderr"))) + (symlink "/proc/self/fd/2" (scope "dev/stderr")) + + ;; File systems in user space (FUSE). + (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229))) (define %host-qemu-ipv4-address (inet-pton AF_INET "10.0.2.10")) @@ -212,7 +215,7 @@ the last argument of `mknod'." (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? - volatile-root? + volatile-root? unionfs (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -277,27 +280,20 @@ to it are lost." (lambda () (if volatile-root? (begin - ;; XXX: For lack of a union file system... (mkdir-p "/real-root") (mount root "/real-root" "ext3" MS_RDONLY) - (mount "none" "/root" "tmpfs") - - ;; XXX: 'copy-recursively' cannot deal with device nodes, so - ;; explicitly avoid /dev. - (for-each (lambda (file) - (unless (string=? "dev" file) - (copy-recursively (string-append "/real-root/" - file) - (string-append "/root/" - file) - #:log (%make-void-port - "w")))) - (scandir "/real-root" - (lambda (file) - (not (member file '("." "..")))))) - - ;; TODO: Unmount /real-root. - ) + (mkdir-p "/rw-root") + (mount "none" "/rw-root" "tmpfs") + + ;; We want read-write /dev nodes. + (make-essential-device-nodes #:root "/rw-root") + + ;; Make /root a union of the tmpfs and the actual root. + (unless (zero? (system* unionfs "-o" + "cow,allow_other,use_ino,dev" + "/rw-root=RW:/real-root=RO" + "/root")) + (error "unionfs failed"))) (mount root "/root" "ext3"))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" -- cgit v1.2.3 From 87d7bb0d02bf0e5985cf4f47fa21aebb62c9260f Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Tue, 15 Apr 2014 14:31:54 +0200 Subject: gnu: gawk: Upgrade to 4.1.1. * gnu/packages/gawk.scm (gawk): Upgrade to 4.1.1. --- gnu/packages/gawk.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/gawk.scm b/gnu/packages/gawk.scm index 9b22a1e5b8..fe422a2014 100644 --- a/gnu/packages/gawk.scm +++ b/gnu/packages/gawk.scm @@ -27,13 +27,13 @@ (define-public gawk (package (name "gawk") - (version "4.1.0") + (version "4.1.1") (source (origin (method url-fetch) (uri (string-append "mirror://gnu/gawk/gawk-" version ".tar.xz")) (sha256 - (base32 "0hin2hswbbd6kd6i4zzvgciwpl5fba8d2s524z8y5qagyz3x010q")))) + (base32 "1nz83vpss8xv7m475sv4qhhj40g74nvcw0y9kwq9ds8wzfmcdm7g")))) (build-system gnu-build-system) (arguments `(#:parallel-tests? #f ; test suite fails in parallel -- cgit v1.2.3 From eda6a07419394f5a7c7bf40dddb50c4b5aa874fb Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Tue, 15 Apr 2014 14:50:33 +0200 Subject: gnu: gawk: Revert previous commit, which should go into core-updates. * gnu/packages/gawk.scm (gawk): Downgrade to 4.1.0 to avoid recompiling almost everything in master. --- gnu/packages/gawk.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/gawk.scm b/gnu/packages/gawk.scm index fe422a2014..9b22a1e5b8 100644 --- a/gnu/packages/gawk.scm +++ b/gnu/packages/gawk.scm @@ -27,13 +27,13 @@ (define-public gawk (package (name "gawk") - (version "4.1.1") + (version "4.1.0") (source (origin (method url-fetch) (uri (string-append "mirror://gnu/gawk/gawk-" version ".tar.xz")) (sha256 - (base32 "1nz83vpss8xv7m475sv4qhhj40g74nvcw0y9kwq9ds8wzfmcdm7g")))) + (base32 "0hin2hswbbd6kd6i4zzvgciwpl5fba8d2s524z8y5qagyz3x010q")))) (build-system gnu-build-system) (arguments `(#:parallel-tests? #f ; test suite fails in parallel -- cgit v1.2.3 From 7e1c735f0bcbbc846a236bd66de7649204d47ab4 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Tue, 15 Apr 2014 14:55:44 +0200 Subject: gnu: wdiff: Upgrade to 1.2.2. * gnu/packages/wdiff.scm (wdiff): Upgrade to 1.2.2. --- gnu/packages/wdiff.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/wdiff.scm b/gnu/packages/wdiff.scm index 774015ef90..06a44a9f40 100644 --- a/gnu/packages/wdiff.scm +++ b/gnu/packages/wdiff.scm @@ -28,7 +28,7 @@ (define-public wdiff (package (name "wdiff") - (version "1.2.1") + (version "1.2.2") (source (origin (method url-fetch) @@ -36,7 +36,7 @@ version ".tar.gz")) (sha256 (base32 - "1gb5hpiyikada9bwz63q3g96zs383iskiir0xsqynqnvq1vd4n41")))) + "0sxgg0ms5lhi4aqqvz1rj4s77yi9wymfm3l3gbjfd1qchy66kzrl")))) (build-system gnu-build-system) (arguments `(#:phases (alist-cons-before -- cgit v1.2.3 From dc8d69760960d6c1467d73658b306e31ccac3332 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Tue, 15 Apr 2014 17:40:23 +0200 Subject: gnu: Add qjson. * gnu/packages/kde.scm (qjson): New variable. --- gnu/packages/kde.scm | 28 ++++++++++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) diff --git a/gnu/packages/kde.scm b/gnu/packages/kde.scm index 2666e58a7a..bb2a7ec997 100644 --- a/gnu/packages/kde.scm +++ b/gnu/packages/kde.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu packages kde) - #:use-module ((guix licenses) #:select (bsd-2 lgpl2.1+)) + #:use-module ((guix licenses) #:select (bsd-2 lgpl2.1 lgpl2.1+)) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system cmake) @@ -78,3 +78,27 @@ (synopsis "Qt 4 multimedia API") (description "KDE desktop environment") (license lgpl2.1+))) + +(define-public qjson + (package + (name "qjson") + (version "0.8.1") + (source (origin + (method url-fetch) + (uri (string-append "https://github.com/flavio/qjson/archive/" + version ".tar.gz")) + (sha256 + (base32 + "163fspi0xc705irv79qw861fmh68pjyla9vx3kqiq6xrdhb9834j")))) + (build-system cmake-build-system) + (inputs + `(("qt" ,qt-4))) + (arguments + `(#:tests? #f)) ; no test target + (home-page "http://qjson.sourceforge.net/") + (synopsis "Qt-based library for handling JSON") + (description "QJson is a Qt-based library that maps JSON data to QVariant +objects and vice versa. JSON arrays are mapped to QVariantList instances, +while JSON objects are mapped to QVariantMap.") + (license lgpl2.1+))) + -- cgit v1.2.3 From ff46707281096b41818737c14933b3cf829abf49 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Tue, 15 Apr 2014 17:46:55 +0200 Subject: gnu: Add libdbusmenu-qt. * gnu/packages/kde.scm (libdbusmenu-qt): New variable. --- gnu/packages/kde.scm | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/gnu/packages/kde.scm b/gnu/packages/kde.scm index bb2a7ec997..0a71329c99 100644 --- a/gnu/packages/kde.scm +++ b/gnu/packages/kde.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu packages kde) - #:use-module ((guix licenses) #:select (bsd-2 lgpl2.1 lgpl2.1+)) + #:use-module ((guix licenses) #:select (bsd-2 lgpl2.0+ lgpl2.1 lgpl2.1+)) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system cmake) @@ -102,3 +102,31 @@ objects and vice versa. JSON arrays are mapped to QVariantList instances, while JSON objects are mapped to QVariantMap.") (license lgpl2.1+))) +(define-public libdbusmenu-qt + (package + (name "libdbusmenu-qt") + (version "0.9.2") + (source (origin + (method url-fetch) + (uri (string-append "https://launchpad.net/" name "/trunk/" + version "/+download/" + name "-" version ".tar.bz2")) + (sha256 + (base32 + "1v0ri5g9xw2z64ik0kx0ra01v8rpjn2kxprrxppkls1wvav1qv5f")))) + (build-system cmake-build-system) + (native-inputs + `(("pkg-config" ,pkg-config))) + (inputs + `(("qjson", qjson) + ("qt" ,qt-4))) + (arguments + `(#:tests? #f ; no check target + #:configure-flags + '("-DWITH_DOC=OFF"))) ; FIXME: drop once input doxygen is available + (home-page "https://launchpad.net/libdbusmenu-qt/") + (synopsis "Qt implementation of the DBusMenu protocol") + (description "The library provides a Qt implementation of the DBusMenu +protocol. The DBusMenu protocol makes it possible for applications to export +and import their menus over DBus.") + (license lgpl2.0+))) -- cgit v1.2.3 From 2b42718b34a7084418a780d553b67ce377171d41 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 15 Apr 2014 22:23:12 +0200 Subject: gnu: man-db: Add specification for $MANPATH. * gnu/packages/man.scm (man-db)[native-search-paths]: New field. --- gnu/packages/man.scm | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/gnu/packages/man.scm b/gnu/packages/man.scm index 2e0b161578..03058a55e1 100644 --- a/gnu/packages/man.scm +++ b/gnu/packages/man.scm @@ -102,6 +102,10 @@ a flexible and convenient way.") ("groff" ,groff) ("less" ,less) ("libpipeline" ,libpipeline))) + (native-search-paths + (list (search-path-specification + (variable "MANPATH") + (directories '("share/man"))))) (home-page "http://man-db.nongnu.org/") (synopsis "Standard Unix documentation system") (description -- cgit v1.2.3 From 158adb661175ed77694a56902a2e347a8192500f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 15 Apr 2014 23:01:53 +0200 Subject: gnu: Add lftp. * gnu/packages/ftp.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. --- gnu-system.am | 1 + gnu/packages/ftp.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+) create mode 100644 gnu/packages/ftp.scm diff --git a/gnu-system.am b/gnu-system.am index fb0139c431..93841e227a 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -72,6 +72,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/fonts.scm \ gnu/packages/fontutils.scm \ gnu/packages/freeipmi.scm \ + gnu/packages/ftp.scm \ gnu/packages/games.scm \ gnu/packages/gawk.scm \ gnu/packages/gcal.scm \ diff --git a/gnu/packages/ftp.scm b/gnu/packages/ftp.scm new file mode 100644 index 0000000000..96af2bf649 --- /dev/null +++ b/gnu/packages/ftp.scm @@ -0,0 +1,56 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu packages ftp) + #:use-module ((guix licenses) #:select (gpl3+)) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module (gnu packages ncurses) + #:use-module (gnu packages readline) + #:use-module (gnu packages pkg-config) + #:use-module (gnu packages gnutls) + #:use-module (gnu packages compression)) + +(define-public lftp + (package + (name "lftp") + (version "4.4.15") + (source (origin + (method url-fetch) + (uri (string-append "http://lftp.yar.ru/ftp/lftp-" + version ".tar.xz")) + (sha256 + (base32 + "0s38vc2ij869dwx3i1c7sk96mqv0hknf3cqf86av59rqnix0px3m")))) + (build-system gnu-build-system) + (native-inputs + `(("pkg-config" ,pkg-config))) + (inputs + `(("zlib" ,zlib) + ("readline" ,readline) + ("gnutls" ,gnutls))) + (home-page "http://lftp.yar.ru/") + (synopsis "Command-line file transfer program") + (description + "LFTP is a sophisticated FTP/HTTP client, and a file transfer program +supporting a number of network protocols. Like Bash, it has job control and +uses the Readline library for input. It has bookmarks, a built-in mirror +command, and can transfer several files in parallel. It was designed with +reliability in mind.") + (license gpl3+))) -- cgit v1.2.3 From 1da34f5ad5dff68b18d4d22002e48a61dc986881 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 15 Apr 2014 23:31:31 +0200 Subject: gnu: Add tcpdump. * gnu/packages/admin.scm (tcpdump): New variable. --- gnu/packages/admin.scm | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm index 774194d87b..bc654dfc75 100644 --- a/gnu/packages/admin.scm +++ b/gnu/packages/admin.scm @@ -480,6 +480,31 @@ network statistics collection, security monitoring, network debugging, etc.") ;; fad-*.c and a couple other files are BSD-4, but the rest is BSD-3. (license bsd-3))) +(define-public tcpdump + (package + (name "tcpdump") + (version "4.5.1") + (source (origin + (method url-fetch) + (uri (string-append "http://www.tcpdump.org/release/tcpdump-" + version ".tar.gz")) + (sha256 + (base32 + "15hb7zkzd66nag102qbv100hcnf7frglbkylmr8adwr8f5jkkaql")))) + (build-system gnu-build-system) + (inputs `(("libpcap" ,libpcap))) + (native-inputs `(("perl" ,perl))) ; for tests + (arguments + ;; XXX: Temporarily disabled until + ;; is resolved. + '(#:tests? #f)) + (home-page "http://www.tcpdump.org/") + (synopsis "Network packet analyzer") + (description + "Tcpdump is a command-line tool to analyze network traffic passing +through the network interface controller.") + (license bsd-3))) + (define-public jnettop (package (name "jnettop") -- cgit v1.2.3 From fccf2fe06b2e2a3d6d57d0a8a86f370586a1f4b0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 15 Apr 2014 23:54:18 +0200 Subject: gnu: Add Rot[t]log. * gnu/packages/admin.scm (rottlog): New variable. --- gnu/packages/admin.scm | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm index bc654dfc75..418c094018 100644 --- a/gnu/packages/admin.scm +++ b/gnu/packages/admin.scm @@ -44,6 +44,7 @@ #:use-module (gnu packages flex) #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) + #:use-module (gnu packages texinfo) #:use-module (gnu packages xorg)) (define-public dmd @@ -576,3 +577,46 @@ by bandwidth they use.") console window to allow commands to be interactively run on multiple servers over ssh connections.") (license gpl2+))) + +(define-public rottlog + (package + (name "rottlog") + (version "0.72.2") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnu/rottlog/rottlog-" + version ".tar.gz")) + (sha256 + (base32 + "0751mb9l2f0jrk3vj6q8ilanifd121dliwk0c34g8k0dlzsv3kd7")) + (modules '((guix build utils))) + (snippet + '(substitute* "Makefile.in" + (("-o \\$\\{LOG_OWN\\} -g \\$\\{LOG_GROUP\\}") + ;; Don't try to chown root. + "") + (("mkdir -p \\$\\(ROTT_STATDIR\\)") + ;; Don't attempt to create /var/lib/rottlog. + "true"))))) + (build-system gnu-build-system) + (arguments + '(#:configure-flags (list (string-append "ROTT_ETCDIR=" + (assoc-ref %outputs "out") + "/etc") + "--localstatedir=/var") + #:phases (alist-cons-after + 'install 'install-info + (lambda _ + (zero? (system* "make" "install-info"))) + %standard-phases))) + (native-inputs `(("texinfo" ,texinfo) + ("util-linux" ,util-linux))) ; for 'cal' + (home-page "http://www.gnu.org/software/rottlog/") + (synopsis "Log rotation and management") + (description + "GNU Rot[t]log is a program for managing log files. It is used to +automatically rotate out log files when they have reached a given size or +according to a given schedule. It can also be used to automatically compress +and archive such logs. Rot[t]log will mail reports of its activity to the +system administrator.") + (license gpl3+))) -- cgit v1.2.3 From 10db1e6c36616e6422f09548192383feda32e673 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Apr 2014 00:18:44 +0200 Subject: gnu: tcpdump: Add dependency on OpenSSL. * gnu/packages/admin.scm (tcpdump)[inputs]: Add OpenSSL. --- gnu/packages/admin.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm index 418c094018..dd3ba33666 100644 --- a/gnu/packages/admin.scm +++ b/gnu/packages/admin.scm @@ -40,6 +40,8 @@ #:select (tar)) #:use-module ((gnu packages compression) #:select (gzip)) + #:use-module ((gnu packages openssl) + #:renamer (symbol-prefix-proc 'o:)) #:use-module (gnu packages bison) #:use-module (gnu packages flex) #:use-module (gnu packages glib) @@ -493,12 +495,9 @@ network statistics collection, security monitoring, network debugging, etc.") (base32 "15hb7zkzd66nag102qbv100hcnf7frglbkylmr8adwr8f5jkkaql")))) (build-system gnu-build-system) - (inputs `(("libpcap" ,libpcap))) + (inputs `(("libpcap" ,libpcap) + ("openssl" ,o:openssl))) (native-inputs `(("perl" ,perl))) ; for tests - (arguments - ;; XXX: Temporarily disabled until - ;; is resolved. - '(#:tests? #f)) (home-page "http://www.tcpdump.org/") (synopsis "Network packet analyzer") (description -- cgit v1.2.3 From 8b32a70b239b608638bd98f536eb05baa6b740f9 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 16 Apr 2014 09:04:52 +0200 Subject: gnu: Add attica. * gnu/packages/kde.scm (attica): New variable. --- gnu/packages/kde.scm | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/gnu/packages/kde.scm b/gnu/packages/kde.scm index 0a71329c99..4d75ea76b4 100644 --- a/gnu/packages/kde.scm +++ b/gnu/packages/kde.scm @@ -130,3 +130,27 @@ while JSON objects are mapped to QVariantMap.") protocol. The DBusMenu protocol makes it possible for applications to export and import their menus over DBus.") (license lgpl2.0+))) + +(define-public attica + (package + (name "attica") + (version "0.4.2") + (source (origin + (method url-fetch) + (uri (string-append "http://download.kde.org/stable/" + name "/" + name "-" version ".tar.bz2")) + (sha256 + (base32 + "1y74gsyzi70dfr9d1f1b08k130rm3jaibsppg8dv5h3211vm771v")))) + (build-system cmake-build-system) + (inputs + `(("qt" ,qt-4))) + (home-page "https://projects.kde.org/projects/kdesupport/attica") + (synopsis "Qt library for the Open Collaboration Services API") + (description "Attica is a Qt library that implements the Open +Collaboration Services API version 1.6. It grants easy access to the +services such as querying information about persons and contents. The +library is used in KNewStuff3 as content provider. In order to integrate +with KDE's Plasma Desktop, a platform plugin exists in kdebase.") + (license lgpl2.1+))) -- cgit v1.2.3 From 8a79ec41e8bec04af4f889a4fdf2b25e3641f12c Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 16 Apr 2014 10:07:52 +0200 Subject: gnu: Add clucene. * gnu/packages/rdf.scm (clucene): New variable. --- gnu/packages/rdf.scm | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index 22cfc2e257..c9364de6f1 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -17,11 +17,12 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu packages rdf) - #:use-module ((guix licenses) #:select (lgpl2.0+ lgpl2.1+)) + #:use-module ((guix licenses) #:select (lgpl2.0+ lgpl2.1 lgpl2.1+)) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system cmake) #:use-module (guix build-system gnu) + #:use-module (gnu packages boost) #:use-module (gnu packages compression) #:use-module (gnu packages curl) #:use-module (gnu packages pkg-config) @@ -60,6 +61,37 @@ Turtle 2013, N-Quads, N-Triples 1.1, Atom 1.0, RSS 1.0, GraphViz DOT, HTML and JSON.") (license lgpl2.1+))) ; or any choice of gpl2+ or asl2.0 +(define-public clucene + (package + (name "clucene") + (version "2.3.3.4") + (source (origin + (method url-fetch) + (uri (string-append "mirror://sourceforge/clucene/" + "clucene-core-unstable/2.3/clucene-core-" + version ".tar.gz")) + (sha256 + (base32 + "1arffdwivig88kkx685pldr784njm0249k0rb1f1plwavlrw9zfx")))) + (build-system cmake-build-system) + (inputs + `(("boost" ,boost) ; could also use bundled copy + ("zlib" ,zlib))) + (arguments + `(#:test-target "cl_test" + #:tests? #f)) ; Tests do not compile, as TestIndexSearcher.cpp uses + ; undeclared usleep. After fixing this, one needs to run + ; "make test" in addition to "make cl_test", then + ; SimpleTest fails. + ; Notice that the library appears to be unmaintained + ; with no reaction to bug reports. + (home-page "http://clucene.sourceforge.net/") + (synopsis "C text indexing and searching library") + (description "CLucene is a high-performance, scalable, cross platform, +full-featured indexing and searching API. It is a port of the very popular +Java Lucene text search engine API to C++.") + (license lgpl2.1))) + (define-public soprano (package (name "soprano") -- cgit v1.2.3 From 7051054a0a2751af840159e3aa68ffd0cdb5cb84 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 16 Apr 2014 10:58:31 +0200 Subject: gnu: clucene: Add patch to indicate linking with clucene-shared, not only clucene-core, to pkgconfig. * gnu/packages/patches/clucene-pkgconfig.patch: New file. * gnu-system.am (dist_patch_DATA): Register patch. * gnu/packages/rdf.scm (clucene): Use patch. --- gnu-system.am | 3 ++- gnu/packages/patches/clucene-pkgconfig.patch | 21 +++++++++++++++++++++ gnu/packages/rdf.scm | 4 +++- 3 files changed, 26 insertions(+), 2 deletions(-) create mode 100644 gnu/packages/patches/clucene-pkgconfig.patch diff --git a/gnu-system.am b/gnu-system.am index 93841e227a..86bdb6986e 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -1,6 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2012, 2013, 2014 Ludovic Courtès -# Copyright © 2013 Andreas Enge +# Copyright © 2013, 2014 Andreas Enge # Copyright © 2013, 2014 Mark H Weaver # # This file is part of GNU Guix. @@ -261,6 +261,7 @@ dist_patch_DATA = \ gnu/packages/patches/bitlbee-fix-tests.patch \ gnu/packages/patches/bitlbee-memset-fix.patch \ gnu/packages/patches/cdparanoia-fpic.patch \ + gnu/packages/patches/clucene-pkgconfig.patch \ gnu/packages/patches/cmake-fix-tests.patch \ gnu/packages/patches/coreutils-dummy-man.patch \ gnu/packages/patches/coreutils-skip-nohup.patch \ diff --git a/gnu/packages/patches/clucene-pkgconfig.patch b/gnu/packages/patches/clucene-pkgconfig.patch new file mode 100644 index 0000000000..5e4825cd3f --- /dev/null +++ b/gnu/packages/patches/clucene-pkgconfig.patch @@ -0,0 +1,21 @@ +Taken from the Debian package. + +From 7be4a19b76d98260cf95040a47935f854a4ba7a4 Mon Sep 17 00:00:00 2001 +From: Valentin Rusu +Date: Sat, 17 Dec 2011 13:47:58 +0100 +Subject: [PATCH] Fix .pc file by adding clucene-shared library + +--- + src/core/libclucene-core.pc.cmake | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +--- a/src/core/libclucene-core.pc.cmake ++++ b/src/core/libclucene-core.pc.cmake +@@ -6,6 +6,6 @@ includedir=${prefix}/include:${prefix}/i + Name: libclucene + Description: CLucene - a C++ search engine, ported from the popular Apache Lucene + Version: @CLUCENE_VERSION_MAJOR@.@CLUCENE_VERSION_MINOR@.@CLUCENE_VERSION_REVISION@.@CLUCENE_VERSION_PATCH@ +-Libs: -L${prefix}/@LIB_DESTINATION@/ -lclucene-core ++Libs: -L${prefix}/@LIB_DESTINATION@/ -lclucene-core -lclucene-shared + Cflags: -I${prefix}/include -I${prefix}/include/CLucene/ext + ~ diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index c9364de6f1..dec2f0e3ee 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -22,6 +22,7 @@ #:use-module (guix download) #:use-module (guix build-system cmake) #:use-module (guix build-system gnu) + #:use-module (gnu packages) #:use-module (gnu packages boost) #:use-module (gnu packages compression) #:use-module (gnu packages curl) @@ -72,7 +73,8 @@ HTML and JSON.") version ".tar.gz")) (sha256 (base32 - "1arffdwivig88kkx685pldr784njm0249k0rb1f1plwavlrw9zfx")))) + "1arffdwivig88kkx685pldr784njm0249k0rb1f1plwavlrw9zfx")) + (patches (list (search-patch "clucene-pkgconfig.patch"))))) (build-system cmake-build-system) (inputs `(("boost" ,boost) ; could also use bundled copy -- cgit v1.2.3 From 58ec6f4ba9e431246a9367d440ded76bb04b18c1 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 16 Apr 2014 11:14:59 +0200 Subject: gnu: Add strigi. * gnu/packages/kde.scm (strigi): New variable. --- gnu/packages/kde.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/gnu/packages/kde.scm b/gnu/packages/kde.scm index 4d75ea76b4..320bcd9d1a 100644 --- a/gnu/packages/kde.scm +++ b/gnu/packages/kde.scm @@ -21,10 +21,17 @@ #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system cmake) + #:use-module (gnu packages compression) + #:use-module (gnu packages geeqie) #:use-module (gnu packages glib) + #:use-module (gnu packages perl) #:use-module (gnu packages pkg-config) #:use-module (gnu packages pulseaudio) + #:use-module (gnu packages python) #:use-module (gnu packages qt) + #:use-module (gnu packages rdf) + #:use-module (gnu packages video) + #:use-module (gnu packages xml) #:use-module (gnu packages xorg)) (define-public automoc4 @@ -154,3 +161,47 @@ services such as querying information about persons and contents. The library is used in KNewStuff3 as content provider. In order to integrate with KDE's Plasma Desktop, a platform plugin exists in kdebase.") (license lgpl2.1+))) + +(define-public strigi + (package + (name "strigi") + (version "0.7.8") + (source (origin + (method url-fetch) + (uri (string-append "http://www.vandenoever.info/software/" + name "/" + name "-" version ".tar.bz2")) + (sha256 + (base32 + "12grxzqwnvbyqw7q1gnz42lypadxmq89vk2qpxczmpmc4nk63r23")))) + (build-system cmake-build-system) + (native-inputs + `(("pkg-config" ,pkg-config))) + ;; FIXME: Add optional inputs XAttr, FAM, Log4cxx + (inputs + `(("clucene" ,clucene) + ("dbus" ,dbus) + ("exiv2" ,exiv2) + ("ffmpeg" ,ffmpeg) + ("libxml2" ,libxml2) + ("perl" ,perl) + ("python" ,python-wrapper) + ("qt" ,qt-4) + ("zlib" ,zlib))) + (arguments + `(#:tests? #f)) ; FIXME: Test 23/25 ProcessInputStreamTest fails. + (home-page "http://www.vandenoever.info/software/strigi/") + (synopsis "Desktop search daemon") + (description "Strigi is a desktop search daemon with the following +main features: +very fast crawling; +very small memory footprint; +no hammering of the system; +pluggable backend, currently clucene and hyperestraier, sqlite3 and xapian +are in the works; +communication between daemon and search program over an abstract interface, +currently a simple socket; +simple interface for implementing plugins for extracting information; +calculation of sha1 for every file crawled +(allows fast finding of duplicates).") + (license lgpl2.0+))) -- cgit v1.2.3 From 395bea2a53ed7398e52a0a85370a554501af5678 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Apr 2014 12:25:25 +0200 Subject: download: Improve progress report output. * guix/build/download.scm (url-fetch): Make current-output-port unbuffered. --- guix/build/download.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/guix/build/download.scm b/guix/build/download.scm index 54115a9de2..5d881b93ee 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -307,7 +307,10 @@ on success." uri) #f))) - (setvbuf (current-output-port) _IOLBF) + ;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means + ;; '\n', not '\r', so it's not appropriate here. + (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-port) _IOLBF) (let try ((uri uri)) -- cgit v1.2.3 From 90f80bf21cce30b92c48958f5a5dcb12942b69a4 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 16 Apr 2014 15:12:46 +0200 Subject: gnu: lua: Compile with -fPIC. * gnu/packages/lua.scm (lua): Add -fPIC to CFLAGS and LDFLAGS. --- gnu/packages/lua.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gnu/packages/lua.scm b/gnu/packages/lua.scm index 991cfc6e67..f2a603bc91 100644 --- a/gnu/packages/lua.scm +++ b/gnu/packages/lua.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013 Cyril Roelandt ;;; Copyright © 2014 Raimon Grau ;;; Copyright © 2014 Mark H Weaver +;;; Copyright © 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,7 +46,7 @@ #:test-target "test" #:phases (alist-replace 'build - (lambda _ (zero? (system* "make" "linux"))) ; XXX: Other OS. + (lambda _ (zero? (system* "make" "CFLAGS=-fPIC" "linux"))) (alist-replace 'install (lambda* (#:key outputs #:allow-other-keys) -- cgit v1.2.3 From 7b29779561122a94290eb075ae35c56767b2e49f Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 16 Apr 2014 15:14:43 +0200 Subject: gnu: lua: Upgrade to 5.2.3. * gnu/packages/lua.scm (lua): Upgrade to 5.2.3. --- gnu/packages/lua.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/lua.scm b/gnu/packages/lua.scm index f2a603bc91..7996c11820 100644 --- a/gnu/packages/lua.scm +++ b/gnu/packages/lua.scm @@ -30,13 +30,13 @@ (define-public lua (package (name "lua") - (version "5.2.1") + (version "5.2.3") (source (origin (method url-fetch) (uri (string-append "http://www.lua.org/ftp/lua-" version ".tar.gz")) (sha256 - (base32 "1rbv2ysq5fdksz7xg07dnrkl8i0gnx855hg4z6b324vng6l4sc34")))) + (base32 "0b8034v1s82n4dg5rzcn12067ha3nxaylp2vdp8gg08kjsbzphhk")))) (build-system gnu-build-system) (inputs `(("readline", readline))) (arguments -- cgit v1.2.3 From 01d3f19b6bec7ed2f4b5bd0c0fbf632498098bba Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 16 Apr 2014 15:31:24 +0200 Subject: gnu: lua: Add older version 5.1.5. * gnu/packages/lua.scm (lua-5.1): New variable. --- gnu/packages/lua.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/gnu/packages/lua.scm b/gnu/packages/lua.scm index 7996c11820..a85c120469 100644 --- a/gnu/packages/lua.scm +++ b/gnu/packages/lua.scm @@ -67,6 +67,16 @@ automatic memory management with incremental garbage collection, making it ideal for configuration, scripting, and rapid prototyping.") (license x11))) +(define-public lua-5.1 + (package (inherit lua) + (version "5.1.5") + (source (origin + (method url-fetch) + (uri (string-append "http://www.lua.org/ftp/lua-" + version ".tar.gz")) + (sha256 + (base32 "0cskd4w0g6rdm2q8q3i4n1h3j8kylhs3rq8mxwl9vwlmlxbgqh16")))))) + (define-public luajit (package (name "luajit") -- cgit v1.2.3 From d5a748e8e324130fff3de147e0809346d68cb306 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 16 Apr 2014 17:46:42 +0200 Subject: gnu: Add vlc. * gnu/packages/video.scm (vlc): New variable. --- gnu/packages/video.scm | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 85 insertions(+) diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm index 7c3bf6b777..cd827d626d 100644 --- a/gnu/packages/video.scm +++ b/gnu/packages/video.scm @@ -22,14 +22,31 @@ #:use-module (guix download) #:use-module (guix build-system gnu) #:use-module (gnu packages algebra) + #:use-module (gnu packages avahi) + #:use-module (gnu packages cdrom) #:use-module (gnu packages compression) #:use-module (gnu packages elf) #:use-module (gnu packages fontutils) + #:use-module (gnu packages gl) + #:use-module (gnu packages glib) + #:use-module (gnu packages gnupg) + #:use-module (gnu packages gnutls) + #:use-module (gnu packages libpng) + #:use-module (gnu packages linux) + #:use-module (gnu packages lua) + #:use-module (gnu packages mp3) #:use-module (gnu packages openssl) #:use-module (gnu packages perl) #:use-module (gnu packages pkg-config) + #:use-module (gnu packages pulseaudio) #:use-module (gnu packages python) + #:use-module (gnu packages qt) + #:use-module (gnu packages sdl) + #:use-module (gnu packages ssh) + #:use-module (gnu packages version-control) #:use-module (gnu packages xiph) + #:use-module (gnu packages xml) + #:use-module (gnu packages xorg) #:use-module (gnu packages yasm)) (define-public ffmpeg @@ -192,3 +209,71 @@ convert and stream audio and video. It includes the libavcodec audio/video codec library.") (license gpl2+))) + +(define-public vlc + (package + (name "vlc") + (version "2.1.4") + (source (origin + (method url-fetch) + (uri (string-append + "http://download.videolan.org/pub/videolan/vlc/" + version "/vlc-" version ".tar.xz")) + (sha256 + (base32 + "1lymhbb2bns73qivdaqanhggjjhyc9fwfgf5ikhng0a74msnqmiy")))) + (build-system gnu-build-system) + (native-inputs + `(("git" ,git) ; needed for a test + ("pkg-config" ,pkg-config))) + ;; FIXME: Add optional inputs once available. + (inputs + `(("alsa-lib" ,alsa-lib) + ("avahi" ,avahi) + ("dbus" ,dbus) + ("flac" ,flac) + ("ffmpeg" ,ffmpeg) + ("fontconfig" ,fontconfig) + ("freetype" ,freetype) + ("gnutls" ,gnutls) + ("libcddb" ,libcddb) + ("libgcrypt" ,libgcrypt) + ("libkate" ,libkate) + ("libmad" ,libmad) + ("libogg" ,libogg) + ("libpng" ,libpng) + ("libsamplerate" ,libsamplerate) + ("libssh2" ,libssh2) + ("libvorbis" ,libvorbis) + ("libtheora" ,libtheora) + ("libxext" ,libxext) + ("libxinerama" ,libxinerama) + ("libxml2" ,libxml2) + ("libxpm" ,libxpm) + ("lua" ,lua-5.1) + ("mesa" ,mesa) + ("opus" ,opus) + ("perl" ,perl) + ("pulseaudio" ,pulseaudio) + ("python" ,python-wrapper) + ("qt" ,qt-4) + ("sdl" ,sdl) + ("sdl-image" ,sdl-image) + ("speex" ,speex) + ("xcb-util-keysyms" ,xcb-util-keysyms))) + (arguments + `(#:configure-flags + `("--disable-a52" ; FIXME: reenable once available + "--disable-mmx" ; FIXME: may be enabled on x86_64 + "--disable-sse" ; 1-4, no separate options available + "--disable-neon" + "--disable-altivec" + ,(string-append "LDFLAGS=-Wl,-rpath -Wl," + (assoc-ref %build-inputs "ffmpeg") + "/lib")))) ; needed for the tests + (home-page "https://www.videolan.org/") + (synopsis "Audio and video framework") + (description "VLC is a cross-platform multimedia player and framework +that plays most multimedia files as well as DVD, Audio CD, VCD, and various +treaming protocols.") + (license gpl2+))) -- cgit v1.2.3 From 8c0519bf83dbb40026e55a5449f4f5942fd3b600 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 17 Apr 2014 18:43:40 +0200 Subject: gnu: xorg: libxxf86dga: Propagate input xf86dgaproto. * gnu/packages/xorg.scm (libxxf86dga): Propagate input xf86dgaproto. --- gnu/packages/xorg.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm index d72054a855..cc9af18a74 100644 --- a/gnu/packages/xorg.scm +++ b/gnu/packages/xorg.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2014 Mark H Weaver ;;; Copyright © 2014 Eric Bavier ;;; @@ -1427,10 +1427,11 @@ tracking.") (base32 "15291ddhyr54sribwbg8hxx2psgzm5gh0pgkw5yrf3zgvdsa67sm")))) (build-system gnu-build-system) + (propagated-inputs + `(("xf86dgaproto" ,xf86dgaproto))) (inputs `(("libx11" ,libx11) - ("libxext" ,libxext) - ("xf86dgaproto" ,xf86dgaproto))) + ("libxext" ,libxext))) (native-inputs `(("pkg-config" ,pkg-config))) (home-page "http://www.x.org/wiki/") -- cgit v1.2.3 From ace6924327142c8557349e7c52c594f71a6c079b Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 17 Apr 2014 18:57:46 +0200 Subject: gnu: Add mplayer. * gnu/packages/video.scm (mplayer): New variable. --- gnu/packages/video.scm | 92 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 91 insertions(+), 1 deletion(-) diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm index cd827d626d..87b4bc66dc 100644 --- a/gnu/packages/video.scm +++ b/gnu/packages/video.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu packages video) - #:use-module ((guix licenses) #:select (gpl2+)) + #:use-module ((guix licenses) #:select (gpl2 gpl2+)) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) @@ -31,6 +31,7 @@ #:use-module (gnu packages glib) #:use-module (gnu packages gnupg) #:use-module (gnu packages gnutls) + #:use-module (gnu packages libjpeg) #:use-module (gnu packages libpng) #:use-module (gnu packages linux) #:use-module (gnu packages lua) @@ -277,3 +278,92 @@ audio/video codec library.") that plays most multimedia files as well as DVD, Audio CD, VCD, and various treaming protocols.") (license gpl2+))) + +(define-public mplayer + (package + (name "mplayer") + (version "1.1.1") + (source (origin + (method url-fetch) + (uri (string-append + "http://www.mplayerhq.hu/MPlayer/releases/MPlayer-" + version ".tar.xz")) + (sha256 + (base32 + "0xlcg7rszrwmw29wqr0plsw5d1rq0hb7vjsq7bmmfsly2z1wg3yf")))) + (build-system gnu-build-system) + ;; FIXME: Add additional inputs once available. + (native-inputs + `(("pkg-config" ,pkg-config))) + (inputs + `(("alsa-lib" ,alsa-lib) + ("cdparanoia" ,cdparanoia) + ("fontconfig" ,fontconfig) + ("freetype" ,freetype) + ("lame" ,lame) +;; ("giflib" ,giflib) ; uses QuantizeBuffer, requires version >= 5 + ("libjpeg" ,libjpeg) + ("libpng" ,libpng) + ("libtheora" ,libtheora) + ("libvorbis" ,libvorbis) + ("libx11" ,libx11) + ("libxxf86dga" ,libxxf86dga) + ("libxinerama" ,libxinerama) + ("libxv" ,libxv) + ("mesa" ,mesa) + ("perl" ,perl) + ("pulseaudio" ,pulseaudio) + ("python" ,python-wrapper) + ("sdl" ,sdl) + ("speex" ,speex) + ("yasm" ,yasm) + ("zlib" ,zlib))) + (arguments + `(#:tests? #f ; no test target + #:phases + (alist-replace + 'configure + ;; configure does not work followed by "SHELL=..." and + ;; "CONFIG_SHELL=..."; set environment variables instead + (lambda* (#:key inputs outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out")) + (libx11 (assoc-ref inputs "libx11"))) + (substitute* "configure" + (("#! /bin/sh") (string-append "#!" (which "bash")))) + (setenv "SHELL" (which "bash")) + (setenv "CONFIG_SHELL" (which "bash")) + (zero? (system* + "./configure" + (string-append "--extra-cflags=-I" + libx11 "/include") ; to detect libx11 + "--disable-tremor-internal" ; forces external libvorbis + (string-append "--prefix=" out) + ;; drop special machine instructions not supported + ;; on all instances of the target + ,@(if (string-prefix? "x86_64" + (or (%current-target-system) + (%current-system))) + '() + '("--disable-3dnow" + "--disable-3dnowext" + "--disable-mmx" + "--disable-mmxext" + "--disable-sse" + "--disable-sse2")) + "--disable-ssse3" + "--disable-altivec" + "--disable-armv5te" + "--disable-armv6" + "--disable-armv6t2" + "--disable-armvfp" + "--disable-neon" + "--disable-thumb" + "--disable-iwmmxt")))) + %standard-phases))) + (home-page "http://www.mplayerhq.hu/design7/news.html") + (synopsis "Audio and video player") + (description "MPlayer is a movie player. It plays most MPEG/VOB, AVI, +Ogg/OGM, VIVO, ASF/WMA/WMV, QT/MOV/MP4, RealMedia, Matroska, NUT, +NuppelVideo, FLI, YUV4MPEG, FILM, RoQ, PVA files. One can watch VideoCD, +SVCD, DVD, 3ivx, DivX 3/4/5, WMV and H.264 movies.") + (license gpl2))) -- cgit v1.2.3 From 50db7d82b3f3ab8ec382132b06a1400c0044b89e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Apr 2014 23:23:34 +0200 Subject: nar: Really really protect the temporary store directory from GC. This is a follow-up to 6071b55e10b7b6e67d77ae058c8744834889e0b4. See for the original report, and for an alternate solution that has been discussed. * guix/nar.scm (temporary-store-file): Remove call to 'add-permanent-root'; don't loop. (with-temporary-store-file): Rewrite using 'with-store' and 'add-temp-root'. --- guix/nar.scm | 39 ++++++++++++++++----------------------- 1 file changed, 16 insertions(+), 23 deletions(-) diff --git a/guix/nar.scm b/guix/nar.scm index 0bf8ac317d..6beda91c02 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -334,36 +334,29 @@ held." (unlock-store-file target))))) (define (temporary-store-file) - "Return the file name of a temporary file created in the store that is -protected from garbage collection." + "Return the file name of a temporary file created in the store." (let* ((template (string-append (%store-prefix) "/guix-XXXXXX")) (port (mkstemp! template))) (close-port port) - - ;; Make sure TEMPLATE is not collected while we populate it. - (add-permanent-root template) - - ;; There's a small window during which the GC could delete the file. Try - ;; again if that happens. - (if (file-exists? template) - (begin - ;; It's up to the caller to create that file or directory. - (delete-file template) - template) - (begin - (remove-permanent-root template) - (temporary-store-file))))) + template)) (define-syntax-rule (with-temporary-store-file name body ...) "Evaluate BODY with NAME bound to the file name of a temporary store item protected from GC." - (let ((name (temporary-store-file))) - (dynamic-wind - (const #t) - (lambda () - body ...) - (lambda () - (remove-permanent-root name))))) + (let loop ((name (temporary-store-file))) + (with-store store + ;; Add NAME to the current process' roots. (Opening this connection to + ;; the daemon allows us to reuse its code that deals with the + ;; per-process roots file.) + (add-temp-root store name) + + ;; There's a window during which GC could delete NAME. Try again when + ;; that happens. + (if (file-exists? name) + (begin + (delete-file name) + body ...) + (loop (temporary-store-file)))))) (define* (restore-one-item port #:key acl (verify-signature? #t) (lock? #t) -- cgit v1.2.3 From 6030d8493e13af81be63c3cee530d44b4dff1ad6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 01:36:31 +0200 Subject: pk-crypto: Use ISO-8859-1 for strings passed to 'gcry_sexp_new'. * guix/pk-crypto.scm (string->canonical-sexp): Pass "ISO-8859-1" as the 2nd argument to 'string->pointer'. * tests/pk-crypto.scm ("version"): New test. ("hash corrupt due to restrictive locale encoding"): New test. --- guix/pk-crypto.scm | 7 ++++++- tests/pk-crypto.scm | 24 ++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 1 deletion(-) diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 481d3f2463..351bf929c5 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -134,8 +134,13 @@ thrown along with 'gcry-error'." (proc (pointer->procedure int ptr `(* * ,size_t ,int)))) (lambda (str) "Parse STR and return the corresponding gcrypt s-expression." + + ;; When STR comes from 'canonical-sexp->string', it may contain + ;; characters that are really meant to be interpreted as bytes as in a C + ;; 'char *'. Thus, convert STR to ISO-8859-1 so the byte values of the + ;; characters are preserved. (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (proc sexp (string->pointer str) 0 1))) + (err (proc sexp (string->pointer str "ISO-8859-1") 0 1))) (if (= 0 err) (pointer->canonical-sexp (dereference-pointer sexp)) (throw 'gcry-error err)))))) diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 294c7f3df8..67bbc83d49 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -64,6 +64,9 @@ (test-begin "pk-crypto") +(test-assert "version" + (gcrypt-version)) + (let ((sexps '("(foo bar)" ;; In Libgcrypt 1.5.3 the following integer is rendered as @@ -142,6 +145,27 @@ 1+ 0))) +(let ((bv (base16-string->bytevector + "5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c"))) + (test-equal "hash corrupt due to restrictive locale encoding" + bv + + ;; In Guix up to 0.6 included this test would fail because at some point + ;; the hash value would be cropped to ASCII. In practice 'guix + ;; authenticate' would produce invalid signatures that would fail + ;; signature verification. + (let ((locale (setlocale LC_ALL))) + (dynamic-wind + (lambda () + (setlocale LC_ALL "C")) + (lambda () + (hash-data->bytevector + (string->canonical-sexp + (canonical-sexp->string + (bytevector->hash-data bv "sha256"))))) + (lambda () + (setlocale LC_ALL locale)))))) + (gc) ;; XXX: The test below is typically too long as it needs to gather enough entropy. -- cgit v1.2.3 From 6f69588529f9898dc4f2defd21603cc4abbaca17 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 11:30:51 +0200 Subject: authenticate: Allow signatures with binary data to be written to stdout. Fixes . * guix/scripts/authenticate.scm (guix-authenticate): Add calls to 'set-port-encoding!' and 'set-port-conversion-strategy!'. Wrap body in 'with-fluids' form that sets '%default-port-encoding' and '%default-port-conversion-strategy'. * tests/guix-authenticate.sh: Add test. * tests/pk-crypto.scm ("hash corrupt due to restrictive locale encoding"): Add reference to bug. --- guix/scripts/authenticate.scm | 55 +++++++++++++++++++++++++------------------ tests/guix-authenticate.sh | 21 +++++++++++++++++ tests/pk-crypto.scm | 2 +- 3 files changed, 54 insertions(+), 24 deletions(-) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 62717bb09c..1b1e0b08ca 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -89,30 +89,39 @@ to stdout upon success." ;;; (define (guix-authenticate . args) - (match args - ;; As invoked by guix-daemon. - (("rsautl" "-sign" "-inkey" key "-in" hash-file) - (call-with-input-file hash-file - (lambda (port) - (sign-with-key key port)))) - ;; As invoked by Nix/Crypto.pm (used by Hydra.) - (("rsautl" "-sign" "-inkey" key) - (sign-with-key key (current-input-port))) - ;; As invoked by guix-daemon. - (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file) - (call-with-input-file signature-file - (lambda (port) - (validate-signature port)))) - ;; As invoked by Nix/Crypto.pm (used by Hydra.) - (("rsautl" "-verify" "-inkey" _ "-pubin") - (validate-signature (current-input-port))) - (("--help") - (display (_ "Usage: guix authenticate OPTION... + ;; Signature sexps written to stdout may contain binary data, so force + ;; ISO-8859-1 encoding so that things are not mangled. See + ;; for details. + (set-port-encoding! (current-output-port) "ISO-8859-1") + (set-port-conversion-strategy! (current-output-port) 'error) + + ;; Same goes for input ports. + (with-fluids ((%default-port-encoding "ISO-8859-1") + (%default-port-conversion-strategy 'error)) + (match args + ;; As invoked by guix-daemon. + (("rsautl" "-sign" "-inkey" key "-in" hash-file) + (call-with-input-file hash-file + (lambda (port) + (sign-with-key key port)))) + ;; As invoked by Nix/Crypto.pm (used by Hydra.) + (("rsautl" "-sign" "-inkey" key) + (sign-with-key key (current-input-port))) + ;; As invoked by guix-daemon. + (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file) + (call-with-input-file signature-file + (lambda (port) + (validate-signature port)))) + ;; As invoked by Nix/Crypto.pm (used by Hydra.) + (("rsautl" "-verify" "-inkey" _ "-pubin") + (validate-signature (current-input-port))) + (("--help") + (display (_ "Usage: guix authenticate OPTION... Sign or verify the signature on the given file. This tool is meant to be used internally by 'guix-daemon'.\n"))) - (("--version") - (show-version-and-exit "guix authenticate")) - (else - (leave (_ "wrong arguments"))))) + (("--version") + (show-version-and-exit "guix authenticate")) + (else + (leave (_ "wrong arguments")))))) ;;; authenticate.scm ends here diff --git a/tests/guix-authenticate.sh b/tests/guix-authenticate.sh index 35ec7ffd6a..72c3d161d7 100644 --- a/tests/guix-authenticate.sh +++ b/tests/guix-authenticate.sh @@ -72,3 +72,24 @@ if guix authenticate rsautl -verify \ then false else true fi + + +# Test for : make sure 'guix authenticate' produces +# valid signatures when run in the C locale. +echo "5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c" \ + > "$hash" + +LC_ALL=C +export LC_ALL + +guix authenticate rsautl -sign \ + -inkey "$abs_top_srcdir/tests/signing-key.sec" \ + -in "$hash" > "$sig" + +guix authenticate rsautl -verify \ + -inkey "$abs_top_srcdir/tests/signing-key.pub" \ + -pubin -in "$sig" +hash2="`guix authenticate rsautl -verify \ + -inkey $abs_top_srcdir/tests/signing-key.pub \ + -pubin -in $sig`" +test "$hash2" = `cat "$hash"` diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 67bbc83d49..f5008f3248 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -153,7 +153,7 @@ ;; In Guix up to 0.6 included this test would fail because at some point ;; the hash value would be cropped to ASCII. In practice 'guix ;; authenticate' would produce invalid signatures that would fail - ;; signature verification. + ;; signature verification. See . (let ((locale (setlocale LC_ALL))) (dynamic-wind (lambda () -- cgit v1.2.3 From 6ef3644e3462d4a98323f556eefa92a6765ed437 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 11:41:52 +0200 Subject: pk-crypto: Add pretty-printer to 'gcry-error' exceptions. * guix/pk-crypto.scm (string->canonical-sexp, sign, generate-key): Pass the procedure name as the first argument to 'throw'. (gcrypt-error-printer): New procedure. : Add call to 'set-exception-printer!'. * guix/nar.scm (restore-one-item): Add 'proc' parameter to 'catch' handler for 'gcry-error. * guix/scripts/archive.scm (%options, generate-key-pair, authorize-key): Likewise. * guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp): Likewise. --- guix/nar.scm | 2 +- guix/pk-crypto.scm | 15 ++++++++++++--- guix/scripts/archive.scm | 6 +++--- guix/scripts/substitute-binary.scm | 2 +- 4 files changed, 17 insertions(+), 8 deletions(-) diff --git a/guix/nar.scm b/guix/nar.scm index 6beda91c02..0a7187c2dd 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -370,7 +370,7 @@ protected from GC." (let ((signature (catch 'gcry-error (lambda () (string->canonical-sexp signature)) - (lambda (err . _) + (lambda (key proc err) (raise (condition (&message (message "signature is not a valid \ diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 351bf929c5..71104128c1 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -143,7 +143,7 @@ thrown along with 'gcry-error'." (err (proc sexp (string->pointer str "ISO-8859-1") 0 1))) (if (= 0 err) (pointer->canonical-sexp (dereference-pointer sexp)) - (throw 'gcry-error err)))))) + (throw 'gcry-error 'string->canonical-sexp err)))))) (define-syntax GCRYSEXP_FMT_ADVANCED (identifier-syntax 3)) @@ -296,7 +296,7 @@ is 'private-key'.)" (canonical-sexp->pointer secret-key)))) (if (= 0 err) (pointer->canonical-sexp (dereference-pointer sig)) - (throw 'gry-error err)))))) + (throw 'gcry-error 'sign err)))))) (define verify (let* ((ptr (libgcrypt-func "gcry_pk_verify")) @@ -318,7 +318,7 @@ s-expression like: (genkey (rsa (nbits 4:2048)))." (err (proc key (canonical-sexp->pointer params)))) (if (zero? err) (pointer->canonical-sexp (dereference-pointer key)) - (throw 'gcry-error err)))))) + (throw 'gcry-error 'generate-key err)))))) (define find-sexp-token (let* ((ptr (libgcrypt-func "gcry_sexp_find_token")) @@ -403,4 +403,13 @@ use pattern matching." (write sexp))))) +(define (gcrypt-error-printer port key args default-printer) + "Print the gcrypt error specified by ARGS." + (match args + ((proc err) + (format port "In procedure ~a: ~a: ~a" + proc (error-source err) (error-string err))))) + +(set-exception-printer! 'gcry-error gcrypt-error-printer) + ;;; pk-crypto.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 0a2e186da6..84904e29da 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -123,7 +123,7 @@ Export/import one or more packages from/to the store.\n")) (string->canonical-sexp (or arg %key-generation-parameters)))) (alist-cons 'generate-key params result))) - (lambda (key err) + (lambda (key proc err) (leave (_ "invalid key generation parameters: ~a: ~a~%") (error-source err) (error-string err)))))) @@ -248,7 +248,7 @@ this may take time...~%")) (let* ((pair (catch 'gcry-error (lambda () (generate-key parameters)) - (lambda (key err) + (lambda (key proc err) (leave (_ "key generation failed: ~a: ~a~%") (error-source err) (error-string err))))) @@ -275,7 +275,7 @@ the input port." (catch 'gcry-error (lambda () (string->canonical-sexp (get-string-all (current-input-port)))) - (lambda (key err) + (lambda (key proc err) (leave (_ "failed to read public key: ~a: ~a~%") (error-source err) (error-string err))))) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 8e35612e3a..c70a4f626c 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -252,7 +252,7 @@ failure." (catch 'gcry-error (lambda () (string->canonical-sexp signature)) - (lambda (err . rest) + (lambda (key proc err) (leave (_ "signature is not a valid \ s-expression: ~s~%") signature)))))))) -- cgit v1.2.3 From 0815f8f9a217ddc2bbe1cf74d10d54aafa2d9063 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 21 Apr 2014 10:04:17 -0400 Subject: gnu: openssl: Fixes for CVE-2010-5298 and extension checking. * gnu/packages/patches/openssl-CVE-2010-5298.patch: New file. * gnu/packages/patches/openssl-extension-checking-fixes.patch: New file. * gnu/packages/openssl.scm (openssl): Add them. * gnu-system.am (dist_patch_DATA): Add them. --- gnu-system.am | 2 ++ gnu/packages/openssl.scm | 6 +++- gnu/packages/patches/openssl-CVE-2010-5298.patch | 27 +++++++++++++++ .../patches/openssl-extension-checking-fixes.patch | 40 ++++++++++++++++++++++ 4 files changed, 74 insertions(+), 1 deletion(-) create mode 100644 gnu/packages/patches/openssl-CVE-2010-5298.patch create mode 100644 gnu/packages/patches/openssl-extension-checking-fixes.patch diff --git a/gnu-system.am b/gnu-system.am index 86bdb6986e..0b18b08500 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -315,6 +315,8 @@ dist_patch_DATA = \ gnu/packages/patches/mcron-install.patch \ gnu/packages/patches/mit-krb5-init-fix.patch \ gnu/packages/patches/mpc123-initialize-ao.patch \ + gnu/packages/patches/openssl-CVE-2010-5298.patch \ + gnu/packages/patches/openssl-extension-checking-fixes.patch \ gnu/packages/patches/patchelf-page-size.patch \ gnu/packages/patches/patchutils-xfail-gendiff-tests.patch \ gnu/packages/patches/perl-no-sys-dirs.patch \ diff --git a/gnu/packages/openssl.scm b/gnu/packages/openssl.scm index 8c12ff9355..eb03bb99c3 100644 --- a/gnu/packages/openssl.scm +++ b/gnu/packages/openssl.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2014 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,7 +35,10 @@ ".tar.gz")) (sha256 (base32 - "0a70qdqccg16nw4bbawa6pjvzn05vfp5wkwg6jl0grch7f683jsk")))) + "0a70qdqccg16nw4bbawa6pjvzn05vfp5wkwg6jl0grch7f683jsk")) + (patches + (list (search-patch "openssl-CVE-2010-5298.patch") + (search-patch "openssl-extension-checking-fixes.patch"))))) (build-system gnu-build-system) (native-inputs `(("perl" ,perl))) (arguments diff --git a/gnu/packages/patches/openssl-CVE-2010-5298.patch b/gnu/packages/patches/openssl-CVE-2010-5298.patch new file mode 100644 index 0000000000..707a24dff0 --- /dev/null +++ b/gnu/packages/patches/openssl-CVE-2010-5298.patch @@ -0,0 +1,27 @@ +From db978be7388852059cf54e42539a363d549c5bfd Mon Sep 17 00:00:00 2001 +From: Kurt Roeckx +Date: Sun, 13 Apr 2014 15:05:30 +0200 +Subject: [PATCH] Don't release the buffer when there still is data in it + +RT: 2167, 3265 +--- + ssl/s3_pkt.c | 3 ++- + 1 file changed, 2 insertions(+), 1 deletion(-) + +diff --git a/ssl/s3_pkt.c b/ssl/s3_pkt.c +index b9e45c7..32e9207 100644 +--- a/ssl/s3_pkt.c ++++ b/ssl/s3_pkt.c +@@ -1055,7 +1055,8 @@ int ssl3_read_bytes(SSL *s, int type, unsigned char *buf, int len, int peek) + { + s->rstate=SSL_ST_READ_HEADER; + rr->off=0; +- if (s->mode & SSL_MODE_RELEASE_BUFFERS) ++ if (s->mode & SSL_MODE_RELEASE_BUFFERS && ++ s->s3->rbuf.left == 0) + ssl3_release_read_buffer(s); + } + } +-- +1.9.1 + diff --git a/gnu/packages/patches/openssl-extension-checking-fixes.patch b/gnu/packages/patches/openssl-extension-checking-fixes.patch new file mode 100644 index 0000000000..3fdd893563 --- /dev/null +++ b/gnu/packages/patches/openssl-extension-checking-fixes.patch @@ -0,0 +1,40 @@ +From 300b9f0b704048f60776881f1d378c74d9c32fbd Mon Sep 17 00:00:00 2001 +From: "Dr. Stephen Henson" +Date: Tue, 15 Apr 2014 18:48:54 +0100 +Subject: [PATCH] Extension checking fixes. + +When looking for an extension we need to set the last found +position to -1 to properly search all extensions. + +PR#3309. +--- + crypto/x509v3/v3_purp.c | 6 +++--- + 1 file changed, 3 insertions(+), 3 deletions(-) + +diff --git a/crypto/x509v3/v3_purp.c b/crypto/x509v3/v3_purp.c +index 6c40c7d..5f931db 100644 +--- a/crypto/x509v3/v3_purp.c ++++ b/crypto/x509v3/v3_purp.c +@@ -389,8 +389,8 @@ static void x509v3_cache_extensions(X509 *x) + /* Handle proxy certificates */ + if((pci=X509_get_ext_d2i(x, NID_proxyCertInfo, NULL, NULL))) { + if (x->ex_flags & EXFLAG_CA +- || X509_get_ext_by_NID(x, NID_subject_alt_name, 0) >= 0 +- || X509_get_ext_by_NID(x, NID_issuer_alt_name, 0) >= 0) { ++ || X509_get_ext_by_NID(x, NID_subject_alt_name, -1) >= 0 ++ || X509_get_ext_by_NID(x, NID_issuer_alt_name, -1) >= 0) { + x->ex_flags |= EXFLAG_INVALID; + } + if (pci->pcPathLengthConstraint) { +@@ -670,7 +670,7 @@ static int check_purpose_timestamp_sign(const X509_PURPOSE *xp, const X509 *x, + return 0; + + /* Extended Key Usage MUST be critical */ +- i_ext = X509_get_ext_by_NID((X509 *) x, NID_ext_key_usage, 0); ++ i_ext = X509_get_ext_by_NID((X509 *) x, NID_ext_key_usage, -1); + if (i_ext >= 0) + { + X509_EXTENSION *ext = X509_get_ext((X509 *) x, i_ext); +-- +1.9.1 + -- cgit v1.2.3 From 571aa6cd81ed0c823586fc1b057d68a5d8dab9c7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 17:44:45 +0200 Subject: gnu: Add GCC 4.9.0. * gnu/packages/gcc.scm (gcc-4.9): New variable. * gnu/packages/base.scm (gcc-toolchain-4.9): New variable. --- gnu/packages/base.scm | 3 +++ gnu/packages/gcc.scm | 11 +++++++++++ 2 files changed, 14 insertions(+) diff --git a/gnu/packages/base.scm b/gnu/packages/base.scm index e6a2242cf0..09cbe8915b 100644 --- a/gnu/packages/base.scm +++ b/gnu/packages/base.scm @@ -1175,4 +1175,7 @@ and binaries, plus debugging symbols in the 'debug' output), and Binutils.") (define-public gcc-toolchain-4.8 (gcc-toolchain gcc-final)) +(define-public gcc-toolchain-4.9 + (gcc-toolchain gcc-4.9)) + ;;; base.scm ends here diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm index cb7817c084..a8d63fc98a 100644 --- a/gnu/packages/gcc.scm +++ b/gnu/packages/gcc.scm @@ -227,6 +227,17 @@ Go. It also includes runtime support libraries for these languages.") (base32 "1j6dwgby4g3p3lz7zkss32ghr45zpdidrg8xvazvn91lqxv25p09")))))) +(define-public gcc-4.9 + (package (inherit gcc-4.7) + (version "4.9.0") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnu/gcc/gcc-" + version "/gcc-" version ".tar.bz2")) + (sha256 + (base32 + "0mqjxpw2klskls00lwx1k24pnyzm3whqxg3hk74c3sddgfllgc5r")))))) + (define (custom-gcc gcc name languages) "Return a custom version of GCC that supports LANGUAGES." (package (inherit gcc) -- cgit v1.2.3 From 1bdb591b74f00813efedce8f1fa854cf8737d706 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 20:41:25 +0200 Subject: gnu: Add mpg123. * gnu/packages/mp3.scm (mpg123): New variable. --- gnu/packages/mp3.scm | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/gnu/packages/mp3.scm b/gnu/packages/mp3.scm index 5eca6c3d35..79ae6eac94 100644 --- a/gnu/packages/mp3.scm +++ b/gnu/packages/mp3.scm @@ -30,6 +30,9 @@ #:use-module (gnu packages pcre) #:use-module (gnu packages pkg-config) #:use-module (gnu packages xiph) + #:use-module (gnu packages pulseaudio) + #:use-module ((gnu packages linux) + #:select (alsa-lib)) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu)) @@ -186,6 +189,30 @@ This package contains the binary.") (license license:gpl2+) (home-page "http://mp3splt.sourceforge.net/mp3splt_page/home.php"))) +(define-public mpg123 + (package + (name "mpg123") + (version "1.19.0") + (source (origin + (method url-fetch) + (uri (string-append "mirror://sourceforge/mpg123/mpg123-" + version ".tar.bz2")) + (sha256 + (base32 + "06xhd68mj9yp0r6l771aq0d7xgnl402a3wm2mvhxmd3w3ph29446")))) + (build-system gnu-build-system) + (arguments '(#:configure-flags '("--with-default-audio=pulse"))) + (native-inputs `(("pkg-config" ,pkg-config))) + (inputs `(("pulseaudio" ,pulseaudio) + ("alsa-lib" ,alsa-lib))) + (home-page "http://www.mpg123.org/") + (synopsis "Console MP3 player and decoder library") + (description + "mpg123 is a real time MPEG 1.0/2.0/2.5 audio player/decoder for layers +1,2 and 3 (MPEG 1.0 layer 3 aka MP3 most commonly tested). It comes with a +command-line tool as well as a C library, libmpg123.") + (license license:lgpl2.1))) + (define-public mpg321 (package (name "mpg321") -- cgit v1.2.3 From 60bbd4f1beb4a63a3220425af73f94a4ae1afc1e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 20:42:00 +0200 Subject: gnu: mplayer: Add mpg123 as an input. * gnu/packages/video.scm (mplayer)[inputs]: Add mpg123. --- gnu/packages/video.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm index 87b4bc66dc..a824d5c5f7 100644 --- a/gnu/packages/video.scm +++ b/gnu/packages/video.scm @@ -301,6 +301,7 @@ treaming protocols.") ("fontconfig" ,fontconfig) ("freetype" ,freetype) ("lame" ,lame) + ("libmpg123" ,mpg123) ; audio codec for MP3 ;; ("giflib" ,giflib) ; uses QuantizeBuffer, requires version >= 5 ("libjpeg" ,libjpeg) ("libpng" ,libpng) -- cgit v1.2.3 From 42b001381e2d892d9c3ac68d3bf3b89c553699a2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Apr 2014 22:15:18 +0200 Subject: gnu: cyrus-sasl: Add alternate source URL. * gnu/packages/cyrus-sasl.scm (cyrus-sasl)[source]: Add alternate URL; the previous one is currently unreachable. --- gnu/packages/cyrus-sasl.scm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/gnu/packages/cyrus-sasl.scm b/gnu/packages/cyrus-sasl.scm index b724d4fc2f..1913f93f0d 100644 --- a/gnu/packages/cyrus-sasl.scm +++ b/gnu/packages/cyrus-sasl.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; ;;; This file is part of GNU Guix. @@ -34,8 +34,12 @@ (version "2.1.26") (source (origin (method url-fetch) - (uri (string-append "ftp://ftp.cyrusimap.org/cyrus-sasl/cyrus-sasl-" version - ".tar.gz")) + (uri (list (string-append + "http://cyrusimap.org/releases/cyrus-sasl-" + version ".tar.gz") + (string-append + "ftp://ftp.cyrusimap.org/cyrus-sasl/cyrus-sasl-" + version ".tar.gz"))) (sha256 (base32 "1hvvbcsg21nlncbgs0cgn3iwlnb3vannzwsp6rwvnn9ba4v53g4g")))) (build-system gnu-build-system) -- cgit v1.2.3 From 0b6f49ef69b4429e05f6e76ccd2ee9e1d07e7776 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Apr 2014 15:47:42 +0200 Subject: system: Factorize (gnu system). * gnu/system.scm (operating-system-accounts, operating-system-etc-directory): New procedures. (operating-system-derivation): Use them. * gnu/services/base.scm (%base-services): Add 'host-name-service' invocation. --- gnu/services/base.scm | 5 ++++- gnu/system.scm | 59 +++++++++++++++++++++++++++++---------------------- 2 files changed, 38 insertions(+), 26 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index d6c1707c6a..3145a657f8 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -186,6 +186,9 @@ This is the GNU operating system, welcome!\n\n"))) (mingetty-service "tty6" #:motd motd) (syslog-service) (guix-service) - (nscd-service)))) + (nscd-service) + + ;; FIXME: Make this an activation-time thing instead of a service. + (host-name-service "gnu")))) ;;; base.scm ends here diff --git a/gnu/system.scm b/gnu/system.scm index 96f721330f..0c330f1564 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -292,42 +292,50 @@ alias ll='ls -l' (mlet %store-monad ((drv (operating-system-profile-derivation os))) (return (derivation->output-path drv)))) -(define (operating-system-derivation os) - "Return a derivation that builds OS." +(define (operating-system-accounts os) + "Return the user accounts for OS, including an obligatory 'root' account." + (mlet %store-monad ((services (sequence %store-monad + (operating-system-services os)))) + (return (cons (user-account + (name "root") + (password "") + (uid 0) (gid 0) + (comment "System administrator") + (home-directory "/root")) + (append (operating-system-users os) + (append-map service-user-accounts + services)))))) + +(define (operating-system-etc-directory os) + "Return that static part of the /etc directory of OS." (mlet* %store-monad - ((services (sequence %store-monad - (cons (host-name-service - (operating-system-host-name os)) - (operating-system-services os)))) + ((services (sequence %store-monad (operating-system-services os))) (pam-services -> ;; Services known to PAM. (delete-duplicates (cons %pam-other-services (append-map service-pam-services services)))) - - (bash-file (package-file bash "bin/bash")) - (dmd-file (package-file (@ (gnu packages admin) dmd) "bin/dmd")) - (accounts -> (cons (user-account - (name "root") - (password "") - (uid 0) (gid 0) - (comment "System administrator") - (home-directory "/root")) - (append (operating-system-users os) - (append-map service-user-accounts - services)))) + (accounts (operating-system-accounts os)) + (profile-drv (operating-system-profile-derivation os)) (groups -> (append (operating-system-groups os) - (append-map service-user-groups services))) + (append-map service-user-groups services)))) + (etc-directory #:accounts accounts #:groups groups + #:pam-services pam-services + #:locale (operating-system-locale os) + #:timezone (operating-system-timezone os) + #:profile profile-drv))) +(define (operating-system-derivation os) + "Return a derivation that builds OS." + (mlet* %store-monad + ((bash-file (package-file bash "bin/bash")) + (dmd-file (package-file (@ (gnu packages admin) dmd) "bin/dmd")) (profile-drv (operating-system-profile-derivation os)) (profile -> (derivation->output-path profile-drv)) - (etc-drv (etc-directory #:accounts accounts #:groups groups - #:pam-services pam-services - #:locale (operating-system-locale os) - #:timezone (operating-system-timezone os) - #:profile profile-drv)) + (etc-drv (operating-system-etc-directory os)) (etc -> (derivation->output-path etc-drv)) - (dmd-conf (dmd-configuration-file services etc)) + (services (sequence %store-monad (operating-system-services os))) + (dmd-conf (dmd-configuration-file services etc)) (boot (text-file "boot" @@ -349,6 +357,7 @@ alias ll='ls -l' ,(string-append "--load=" boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries)) + (accounts (operating-system-accounts os)) (extras (links (delete-duplicates (append (append-map service-inputs services) (append-map user-account-inputs accounts)))))) -- cgit v1.2.3 From 2106d3fc8112581d1d869a13b9a6a29ab4e48b57 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Apr 2014 16:52:14 +0200 Subject: system: Add 'operating-system-boot-script'. * gnu/system.scm (operating-system-boot-script): New procedure. (operating-system-derivation): Use it. Remove DMD-CONF from the file union. Add BOOT-DRV to the inputs. --- gnu/system.scm | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index 0c330f1564..93858e972a 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -325,23 +325,29 @@ alias ll='ls -l' #:timezone (operating-system-timezone os) #:profile profile-drv))) +(define (operating-system-boot-script os) + "Return the boot script for OS---i.e., the code started by the initrd once +we're running in the final root." + (mlet* %store-monad + ((services (sequence %store-monad (operating-system-services os))) + (etc (operating-system-etc-directory os)) + (dmd-conf (dmd-configuration-file services + (derivation->output-path etc)))) + ;; FIXME: Use 'sexp-file' or similar. + (text-file* "boot" + "(execl \"" dmd "/bin/dmd\" \"dmd\" + \"--config\" \"" dmd-conf "\")"))) + (define (operating-system-derivation os) "Return a derivation that builds OS." (mlet* %store-monad - ((bash-file (package-file bash "bin/bash")) - (dmd-file (package-file (@ (gnu packages admin) dmd) "bin/dmd")) - (profile-drv (operating-system-profile-derivation os)) + ((profile-drv (operating-system-profile-derivation os)) (profile -> (derivation->output-path profile-drv)) (etc-drv (operating-system-etc-directory os)) (etc -> (derivation->output-path etc-drv)) (services (sequence %store-monad (operating-system-services os))) - (dmd-conf (dmd-configuration-file services etc)) - - - (boot (text-file "boot" - (object->string - `(execl ,dmd-file "dmd" - "--config" ,dmd-conf)))) + (boot-drv (operating-system-boot-script os)) + (boot -> (derivation->output-path boot-drv)) (kernel -> (operating-system-kernel os)) (kernel-dir (package-file kernel)) (initrd (operating-system-initrd os)) @@ -364,12 +370,12 @@ alias ll='ls -l' (file-union `(("boot" ,boot) ("kernel" ,kernel-dir) ("initrd" ,initrd-file) - ("dmd.conf" ,dmd-conf) ("profile" ,profile) ("grub.cfg" ,grub.cfg) ("etc" ,etc) ("system-inputs" ,(derivation->output-path extras))) - #:inputs `(("kernel" ,kernel) + #:inputs `(("boot" ,boot-drv) + ("kernel" ,kernel) ("initrd" ,initrd) ("bash" ,bash) ("profile" ,profile-drv) -- cgit v1.2.3 From c47f0d8b71cd3b2dd1ed9fb90a997f5abecddb8b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Apr 2014 16:53:36 +0200 Subject: vm: Clarify 'system-qemu-image/shared-store-script'. * gnu/system/vm.scm (system-qemu-image/shared-store-script): Move 'initrd' definition to the top-level. Have a single definition of 'initrd', 'image', and 'os-drv'. --- gnu/system/vm.scm | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 069ac3093a..c491336ccb 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -341,18 +341,21 @@ with the host." (graphic? #t)) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host." - (let* ((initrd (qemu-initrd #:mounts `((9p "store" ,(%store-prefix))) - #:volatile-root? #t)) - (os (operating-system (inherit os) (initrd initrd)))) + (define initrd + (qemu-initrd #:mounts `((9p "store" ,(%store-prefix))) + #:volatile-root? #t)) + + (mlet* %store-monad + ((os -> (operating-system (inherit os) (initrd initrd))) + (os-drv (operating-system-derivation os)) + (initrd initrd) + (image (system-qemu-image/shared-store os))) (define builder - (mlet %store-monad ((image (system-qemu-image/shared-store os)) - (qemu (package-file qemu + (mlet %store-monad ((qemu (package-file qemu "bin/qemu-system-x86_64")) (bash (package-file bash "bin/sh")) (kernel (package-file (operating-system-kernel os) - "bzImage")) - (initrd initrd) - (os-drv (operating-system-derivation os))) + "bzImage"))) (return `(let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (port) @@ -371,17 +374,14 @@ exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \ (chmod out #o555) #t)))) - (mlet %store-monad ((image (system-qemu-image/shared-store os)) - (initrd initrd) - (qemu (package->derivation qemu)) + (mlet %store-monad ((qemu (package->derivation qemu)) (bash (package->derivation bash)) - (os (operating-system-derivation os)) (builder builder)) (derivation-expression "run-vm.sh" builder #:inputs `(("qemu" ,qemu) ("image" ,image) ("bash" ,bash) ("initrd" ,initrd) - ("os" ,os)))))) + ("os" ,os-drv)))))) ;;; vm.scm ends here -- cgit v1.2.3 From 99fa3024b8a77d1a1fc72487252f3bc32f6f1082 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 24 Apr 2014 11:09:15 +0200 Subject: gnu: gp2c: Upgrade to 0.0.9pl1. * gnu/packages/algebra.scm (gp2c): Upgrade to 0.0.9pl1. --- gnu/packages/algebra.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/algebra.scm b/gnu/packages/algebra.scm index 86f8361a63..0318cb531e 100644 --- a/gnu/packages/algebra.scm +++ b/gnu/packages/algebra.scm @@ -123,14 +123,14 @@ PARI is also available as a C library to allow for faster computations.") (define-public gp2c (package (name "gp2c") - (version "0.0.8pl1") + (version "0.0.9pl1") (source (origin (method url-fetch) (uri (string-append "http://pari.math.u-bordeaux.fr/pub/pari/GP2C/gp2c-" version ".tar.gz")) (sha256 (base32 - "0r1xrshgx0db2snmacwvg5r99fhd9rpblcfs86pfsp23hnjxj9i0")))) + "1p36060vwhn38j77r4c3jqyaslvhvgm6fdw2486k7krxk5ai7ph5")))) (build-system gnu-build-system) (native-inputs `(("perl" ,perl))) (inputs `(("pari-gp" ,pari-gp))) -- cgit v1.2.3 From c0412fedf85034d9e00e84e5ae5c415df1df6284 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 24 Apr 2014 17:39:12 +0200 Subject: build: Add missing function checks for optional daemon features. * config-daemon.ac: Check for lchown, posix_fallocate, vfork, sched_setaffinity, statvfs, nanosleep, and strsignal. As a side effect, this enables daemon features depending on the corresponding feature test macros. --- config-daemon.ac | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/config-daemon.ac b/config-daemon.ac index 1169bb6ef4..08a72a0c4c 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -67,9 +67,14 @@ if test "x$guix_build_daemon" = "xyes"; then AC_CHECK_FUNCS([chroot unshare]) AC_CHECK_HEADERS([sched.h sys/param.h sys/mount.h]) - dnl Check for lutimes, optionally used for changing the mtime of - dnl symlinks. - AC_CHECK_FUNCS([lutimes]) + dnl lutimes and lchown: used when canonicalizing store items. + dnl posix_fallocate: used when extracting archives. + dnl vfork: to speed up spawning of helper programs. + dnl sched_setaffinity: to improve RPC locality. + dnl statvfs: to detect disk-full conditions. + dnl strsignal: for error reporting. + AC_CHECK_FUNCS([lutimes lchown posix_fallocate vfork sched_setaffinity \ + statvfs nanosleep strsignal]) dnl Check whether the store optimiser can optimise symlinks. AC_MSG_CHECKING([whether it is possible to create a link to a symlink]) -- cgit v1.2.3 From 436d4d1fbb425c26d716e9f789f1284ec088cc86 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Fri, 25 Apr 2014 00:03:36 +0200 Subject: gnu: Add doxygen. * gnu/packages/doxygen.scm: New file. * gnu/packages/patches/doxygen-test.patch, gnu/packages/patches/doxygen-tmake.patch: New files. * gnu-system.am (GNU_SYSTEM_MODULES, dist_patch_DATA): Register the new files. --- gnu-system.am | 3 ++ gnu/packages/doxygen.scm | 75 ++++++++++++++++++++++++++++++++ gnu/packages/patches/doxygen-test.patch | 38 ++++++++++++++++ gnu/packages/patches/doxygen-tmake.patch | 24 ++++++++++ 4 files changed, 140 insertions(+) create mode 100644 gnu/packages/doxygen.scm create mode 100644 gnu/packages/patches/doxygen-test.patch create mode 100644 gnu/packages/patches/doxygen-tmake.patch diff --git a/gnu-system.am b/gnu-system.am index 0b18b08500..3cc946a3ca 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -61,6 +61,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/ddrescue.scm \ gnu/packages/dictionaries.scm \ gnu/packages/docbook.scm \ + gnu/packages/doxygen.scm \ gnu/packages/dwm.scm \ gnu/packages/ed.scm \ gnu/packages/elf.scm \ @@ -271,6 +272,8 @@ dist_patch_DATA = \ gnu/packages/patches/diffutils-gets-undeclared.patch \ gnu/packages/patches/dmd-getpw.patch \ gnu/packages/patches/dmd-tests-longer-sleeps.patch \ + gnu/packages/patches/doxygen-test.patch \ + gnu/packages/patches/doxygen-tmake.patch \ gnu/packages/patches/emacs-configure-sh.patch \ gnu/packages/patches/findutils-absolute-paths.patch \ gnu/packages/patches/flac-fix-memcmp-not-declared.patch \ diff --git a/gnu/packages/doxygen.scm b/gnu/packages/doxygen.scm new file mode 100644 index 0000000000..c63a3e6ea1 --- /dev/null +++ b/gnu/packages/doxygen.scm @@ -0,0 +1,75 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Andreas Enge +;;; +;;; 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 . + +(define-module (gnu packages doxygen) + #:use-module ((guix licenses) #:select (gpl3+)) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module (gnu packages) + #:use-module (gnu packages bison) + #:use-module (gnu packages flex) + #:use-module (gnu packages perl) + #:use-module (gnu packages xml) + #:use-module (gnu packages python)) + +(define-public doxygen + (package + (name "doxygen") + (version "1.8.7") + (source (origin + (method url-fetch) + (uri (string-append "http://ftp.stack.nl/pub/users/dimitri/" + name "-" version ".src.tar.gz")) + (sha256 + (base32 + "1ng3dv5fninhfi2fj75ghkr5jwsl653fxv2sxhaswj11x2vcdsn6")) + (patches (list (search-patch "doxygen-tmake.patch") + (search-patch "doxygen-test.patch"))))) + (build-system gnu-build-system) + ;; The presence of graphviz is checked, but it does not seem to influence + ;; the output: Even after adding it as an input, no reference to it is + ;; retained. It might be an option to add it as a propagated input, + ;; only so that it becomes installed in the user profile. + (native-inputs + `(("bison" ,bison) + ("flex" ,flex) + ("libxml2" ,libxml2) ; provides xmllint for the tests + ("perl" ,perl) ; for the tests + ("python" ,python-2))) ; for creating the documentation + (arguments + `(#:test-target "test" + #:phases + (alist-replace + 'configure + (lambda* (#:key outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + ;; do not pass "--enable-fast-install", which makes the + ;; configure process fail + (zero? (system* + "./configure" + "--prefix" out)))) + %standard-phases))) + (home-page "http://www.stack.nl/~dimitri/doxygen/") + (synopsis "tool for generating documentation from annotated sources") + (description "Doxygen is the de facto standard tool for generating +documentation from annotated C++ sources, but it also supports other popular +programming languages such as C, Objective-C, C#, PHP, Java, Python, +IDL (Corba, Microsoft, and UNO/OpenOffice flavors), Fortran, VHDL, Tcl, +and to some extent D.") + (license gpl3+))) diff --git a/gnu/packages/patches/doxygen-test.patch b/gnu/packages/patches/doxygen-test.patch new file mode 100644 index 0000000000..7a7f4e963f --- /dev/null +++ b/gnu/packages/patches/doxygen-test.patch @@ -0,0 +1,38 @@ +Modify the expected outcome of test 012 so that it passes when bibtex is +not in the path, as we do not wish to add texlive as an input just for this +test. + +diff -u -r doxygen-1.8.7.orig/testing/012/citelist.xml doxygen-1.8.7/testing/012/citelist.xml +--- doxygen-1.8.7.orig/testing/012/citelist.xml 2014-04-24 23:43:34.000000000 +0200 ++++ doxygen-1.8.7/testing/012/citelist.xml 2014-04-24 23:49:43.000000000 +0200 +@@ -4,17 +4,6 @@ + citelist + Bibliography + +- +- +- +- [1] +- +- +- DonaldE. Knuth. Tex and Metafont, New Directions in Typesetting. American Mathematical Society and Digital Press, Stanford, 1979. +- +- +- +- + + + +diff -u -r doxygen-1.8.7.orig/testing/012/indexpage.xml doxygen-1.8.7/testing/012/indexpage.xml +--- doxygen-1.8.7.orig/testing/012/indexpage.xml 2014-04-24 23:43:34.000000000 +0200 ++++ doxygen-1.8.7/testing/012/indexpage.xml 2014-04-24 23:44:05.000000000 +0200 +@@ -4,7 +4,7 @@ + index + My Project + +- See [1] for more info. ++ See knuth79 for more info. + + + +Nur in doxygen-1.8.7/testing: test_output_012. diff --git a/gnu/packages/patches/doxygen-tmake.patch b/gnu/packages/patches/doxygen-tmake.patch new file mode 100644 index 0000000000..3579243702 --- /dev/null +++ b/gnu/packages/patches/doxygen-tmake.patch @@ -0,0 +1,24 @@ +Fix the `check_unix' function, which looks for `/bin/uname' to determine +whether we're on a Unix-like system. +Taken from nixpkgs. + +--- doxygen-1.5.8/tmake/bin/tmake 2008-12-06 14:16:20.000000000 +0100 ++++ doxygen-1.5.8/tmake/bin/tmake 2009-03-05 11:29:55.000000000 +0100 +@@ -234,17 +234,7 @@ sub tmake_verb { + # + + sub check_unix { +- my($r); +- $r = 0; +- if ( -f "/bin/uname" ) { +- $r = 1; +- (-f "\\bin\\uname") && ($r = 0); +- } +- if ( -f "/usr/bin/uname" ) { +- $r = 1; +- (-f "\\usr\\bin\\uname") && ($r = 0); +- } +- return $r; ++ return 1; + } + -- cgit v1.2.3 From eb78797163abc06f032ac76a6c8a1e6e579b9de4 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Fri, 25 Apr 2014 00:09:59 +0200 Subject: gnu: libdbusmenu-qt: Add native input doxygen for building the documentation, and make input qjson native. * gnu/packages/kde.scm (libdbusmenu-qt): Add native input doxygen for building the documentation. Make input qjson native, as it is needed only for the tests. --- gnu/packages/kde.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/gnu/packages/kde.scm b/gnu/packages/kde.scm index 320bcd9d1a..bc5d2d533a 100644 --- a/gnu/packages/kde.scm +++ b/gnu/packages/kde.scm @@ -22,6 +22,7 @@ #:use-module (guix download) #:use-module (guix build-system cmake) #:use-module (gnu packages compression) + #:use-module (gnu packages doxygen) #:use-module (gnu packages geeqie) #:use-module (gnu packages glib) #:use-module (gnu packages perl) @@ -123,14 +124,13 @@ while JSON objects are mapped to QVariantMap.") "1v0ri5g9xw2z64ik0kx0ra01v8rpjn2kxprrxppkls1wvav1qv5f")))) (build-system cmake-build-system) (native-inputs - `(("pkg-config" ,pkg-config))) + `(("doxygen" ,doxygen) ; used for static documentation + ("pkg-config" ,pkg-config) + ("qjson", qjson))) ; used for the tests (inputs - `(("qjson", qjson) - ("qt" ,qt-4))) + `(("qt" ,qt-4))) (arguments - `(#:tests? #f ; no check target - #:configure-flags - '("-DWITH_DOC=OFF"))) ; FIXME: drop once input doxygen is available + `(#:tests? #f)) ; no check target (home-page "https://launchpad.net/libdbusmenu-qt/") (synopsis "Qt implementation of the DBusMenu protocol") (description "The library provides a Qt implementation of the DBusMenu -- cgit v1.2.3 From b01932868ee2b069f7de531a71c1ccb743b74cb4 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Fri, 25 Apr 2014 00:16:30 +0200 Subject: gnu: libmpdclient: Add native input doxygen. * gnu/packages/mpd.scm (libmpdclient): Add native input doxygen. --- gnu/packages/mpd.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/gnu/packages/mpd.scm b/gnu/packages/mpd.scm index 04b34eaf87..5841e8be7b 100644 --- a/gnu/packages/mpd.scm +++ b/gnu/packages/mpd.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson +;;; Copyright © 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (gnu packages avahi) #:use-module (gnu packages compression) #:use-module (gnu packages curl) + #:use-module (gnu packages doxygen) #:use-module (gnu packages glib) #:use-module (gnu packages linux) #:use-module (gnu packages mp3) @@ -53,9 +55,7 @@ (base32 "0csb9r3nlmbwpiryixjr5k33x3zqd61xjhwmlps3a6prck1n1xw2")))) (build-system gnu-build-system) - (arguments - ;; FIXME: Needs doxygen. - '(#:configure-flags '("--disable-documentation"))) + (native-inputs `(("doxygen" ,doxygen))) (synopsis "Music Player Daemon client library") (description "A stable, documented, asynchronous API library for interfacing MPD in the C, C++ & Objective C languages.") -- cgit v1.2.3 From 707d3e24a23774b8c2e0c6b287de8d6554fae078 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Fri, 25 Apr 2014 00:20:31 +0200 Subject: gnu: libkate: Add native input doxygen and make input pkg-config native. * gnu/packages/xiph.scm (libkate): Add native input doxygen. Make input pkg-config native. --- gnu/packages/xiph.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/gnu/packages/xiph.scm b/gnu/packages/xiph.scm index 2de9074f28..66c6c1373d 100644 --- a/gnu/packages/xiph.scm +++ b/gnu/packages/xiph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2013 David Thompson ;;; Copyright © 2014 Sree Harsha Totakura @@ -25,6 +25,7 @@ #:use-module (gnu packages bison) #:use-module (gnu packages compression) #:use-module (gnu packages curl) + #:use-module (gnu packages doxygen) #:use-module (gnu packages libpng) #:use-module (gnu packages pkg-config) #:use-module (gnu packages python) @@ -231,12 +232,13 @@ meaning that audio is compressed in FLAC without any loss in quality.") (base32 "0s3vr2nxfxlf1k75iqpp4l78yf4gil3f0v778kvlngbchvaq23n4")))) (build-system gnu-build-system) - ;; FIXME: Add optional inputs doxygen (for documentation) and liboggz + (native-inputs `(("doxygen" ,doxygen) + ("pkg-config" ,pkg-config))) + ;; FIXME: Add optional input liboggz (inputs `(("bison" ,bison) ("libogg" ,libogg) ("libpng" ,libpng) - ("pkg-config" ,pkg-config) - ("python" ,python-wrapper) +("python" ,python-wrapper) ("zlib" ,zlib))) (synopsis "kate, a karaoke and text codec for embedding in ogg") (description -- cgit v1.2.3 From 9e57c1b58742c5eda3edcccd9397ef28dbfb7f5e Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Fri, 25 Apr 2014 00:31:41 +0200 Subject: gnu: doxygen: Add propagated input graphviz. * gnu/packages/doxygen.scm (doxygen): Add propagated input graphviz. --- gnu/packages/doxygen.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/gnu/packages/doxygen.scm b/gnu/packages/doxygen.scm index c63a3e6ea1..8c51ae858e 100644 --- a/gnu/packages/doxygen.scm +++ b/gnu/packages/doxygen.scm @@ -24,6 +24,7 @@ #:use-module (gnu packages) #:use-module (gnu packages bison) #:use-module (gnu packages flex) + #:use-module (gnu packages graphviz) #:use-module (gnu packages perl) #:use-module (gnu packages xml) #:use-module (gnu packages python)) @@ -42,16 +43,14 @@ (patches (list (search-patch "doxygen-tmake.patch") (search-patch "doxygen-test.patch"))))) (build-system gnu-build-system) - ;; The presence of graphviz is checked, but it does not seem to influence - ;; the output: Even after adding it as an input, no reference to it is - ;; retained. It might be an option to add it as a propagated input, - ;; only so that it becomes installed in the user profile. (native-inputs `(("bison" ,bison) ("flex" ,flex) ("libxml2" ,libxml2) ; provides xmllint for the tests ("perl" ,perl) ; for the tests ("python" ,python-2))) ; for creating the documentation + (propagated-inputs + `(("graphviz" ,graphviz))) (arguments `(#:test-target "test" #:phases -- cgit v1.2.3 From 5d17cf8eb96e7f266c3ec8d9e512389d1875401b Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Fri, 25 Apr 2014 00:24:48 +0200 Subject: gnu: soprano: Add native input doxygen. * gnu/packages/rdf.scm (soprano): Add native input doxygen. --- gnu/packages/rdf.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index dec2f0e3ee..7bf75eeb28 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -26,6 +26,7 @@ #:use-module (gnu packages boost) #:use-module (gnu packages compression) #:use-module (gnu packages curl) + #:use-module (gnu packages doxygen) #:use-module (gnu packages pkg-config) #:use-module (gnu packages qt) #:use-module (gnu packages xml)) @@ -112,9 +113,10 @@ Java Lucene text search engine API to C++.") (base32 "08gb5d8bgy7vc6qd6r1kkmmc5rli67dlglpjqjlahpnvs26r1cwl")))) (build-system cmake-build-system) - ;; FIXME: Add optional dependencies: Redland, odbci, clucene; doxygen + ;; FIXME: Add optional dependencies: Redland, odbci, clucene (native-inputs - `(("pkg-config" ,pkg-config))) + `(("doxygen" ,doxygen) + ("pkg-config" ,pkg-config))) (inputs `(("qt" ,qt-4) ("raptor2" ,raptor2))) -- cgit v1.2.3 From 06ed59825ecc0dc78d4d16d06c129e2f4879201a Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sun, 27 Apr 2014 11:09:07 +0200 Subject: guix: cmake: Add input and package libraries to the rpath, and adapt package definitions accordingly. * guix/build/cmake-build-system.scm (configure): Add flags. * gnu/packages/maths.scm (lapack): Drop special code. * gnu/packages/ssh.scm (libssh): Drop special code. * gnu/packages/slim.scm (slim): Drop special code and enable shared library. Co-authored-by: Eric Bavier --- gnu/packages/maths.scm | 35 +++-------------------------------- gnu/packages/slim.scm | 12 +++--------- gnu/packages/ssh.scm | 35 +++-------------------------------- guix/build/cmake-build-system.scm | 5 +++++ 4 files changed, 14 insertions(+), 73 deletions(-) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 68c326752c..232b79b312 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 John Darrington ;;; @@ -190,43 +190,14 @@ output in text, PostScript, PDF or HTML.") (inputs `(("fortran" ,gfortran-4.8) ("python" ,python-2))) (arguments - `(#:modules ((guix build cmake-build-system) - (guix build utils) - (guix build rpath) - (srfi srfi-1)) - #:imported-modules ((guix build cmake-build-system) - (guix build gnu-build-system) - (guix build utils) - (guix build rpath)) - #:configure-flags '("-DBUILD_SHARED_LIBS:BOOL=YES") + `(#:configure-flags '("-DBUILD_SHARED_LIBS:BOOL=YES") #:phases (alist-cons-before 'check 'patch-python (lambda* (#:key inputs #:allow-other-keys) (let ((python (assoc-ref inputs "python"))) (substitute* "lapack_testing.py" (("/usr/bin/env python") python)))) - (alist-cons-after - 'strip 'add-libs-to-runpath - (lambda* (#:key inputs outputs #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (fortran (assoc-ref inputs "fortran")) - (libc (assoc-ref inputs "libc")) - (rpaths `(,(string-append fortran "/lib64") - ,(string-append fortran "/lib") - ,(string-append libc "/lib") - ,(string-append out "/lib")))) - ;; Set RUNPATH for all libraries - (with-directory-excursion out - (for-each - (lambda (lib) - (let ((lib-rpaths (file-rpath lib))) - (for-each - (lambda (dir) - (or (member dir lib-rpaths) - (augment-rpath lib dir))) - rpaths))) - (find-files "lib" ".*so$"))))) - %standard-phases)))) + %standard-phases))) (synopsis "Library for numerical linear algebra") (description "LAPACK is a Fortran 90 library for solving the most commonly occurring diff --git a/gnu/packages/slim.scm b/gnu/packages/slim.scm index f25b070f3c..cea3748985 100644 --- a/gnu/packages/slim.scm +++ b/gnu/packages/slim.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Guy Grant ;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,15 +76,8 @@ ;; "systemd". Strip that. ""))) %standard-phases) - #:configure-flags '("-DUSE_PAM=yes" "-DUSE_CONSOLEKIT=no" - - ;; Don't build libslim.so, because then the build - ;; system is unable to set the right RUNPATH on the - ;; 'slim' binary. - "-DBUILD_SHARED_LIBS=OFF" - - ;; Leave a valid RUNPATH upon install. - "-DCMAKE_SKIP_BUILD_RPATH=ON") + #:configure-flags '("-DUSE_PAM=yes" + "-DUSE_CONSOLEKIT=no") #:tests? #f)) (home-page "http://slim.berlios.de/") (synopsis "Desktop-independent graphcal login manager for X11") diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm index 51e1990168..c8ed3be4a7 100644 --- a/gnu/packages/ssh.scm +++ b/gnu/packages/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2014 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -53,39 +53,10 @@ "1jyaj9h1iglvn02hrvcchbx8ycjpj8b91h8mi459k7q5jp2xgd9b")))) (build-system cmake-build-system) (arguments - '(#:configure-flags '("-DWITH_GCRYPT=ON" - - ;; Leave a valid RUNPATH upon install. - "-DCMAKE_SKIP_BUILD_RPATH=ON") + '(#:configure-flags '("-DWITH_GCRYPT=ON") ;; TODO: Add 'CMockery' and '-DWITH_TESTING=ON' for the test suite. - #:tests? #f - - #:modules ((guix build cmake-build-system) - (guix build utils) - (guix build rpath)) - #:imported-modules ((guix build gnu-build-system) - (guix build cmake-build-system) - (guix build utils) - (guix build rpath)) - - #:phases (alist-cons-after - 'install 'augment-runpath - (lambda* (#:key outputs #:allow-other-keys) - ;; libssh_threads.so NEEDs libssh.so, so add $libdir to its - ;; RUNPATH. - (define (dereference file) - (let ((target (false-if-exception (readlink file)))) - (if target - (dereference target) - file))) - - (let* ((out (assoc-ref outputs "out")) - (lib (string-append out "/lib"))) - (with-directory-excursion lib - (augment-rpath (dereference "libssh_threads.so") - lib)))) - %standard-phases))) + #:tests? #f)) (inputs `(("zlib" ,zlib) ;; Link against an older gcrypt, because libssh tries to access ;; fields of 'gcry_thread_cbs' that are now private: diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm index 75998568bc..144552e8de 100644 --- a/guix/build/cmake-build-system.scm +++ b/guix/build/cmake-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Ludovic Courtès ;;; Copyright © 2013 Cyril Roelandt +;;; Copyright © 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -48,6 +49,10 @@ (let ((args `(,srcdir ,(string-append "-DCMAKE_INSTALL_PREFIX=" out) + ;; add input libraries to rpath + "-DCMAKE_INSTALL_RPATH_USE_LINK_PATH=TRUE" + ;; add (other) libraries of the project itself to rpath + ,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib") ,@configure-flags))) (setenv "CMAKE_LIBRARY_PATH" (getenv "LIBRARY_PATH")) (setenv "CMAKE_INCLUDE_PATH" (getenv "CPATH")) -- cgit v1.2.3 From c69fe8306d7fa69fa67c31b296ae25353f73a2a0 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Mon, 28 Apr 2014 20:09:27 +0200 Subject: gnu: soprano: Upgrade to 2.9.4. * gnu/packages/rdf.scm (soprano): Upgrade to 2.9.4. --- gnu/packages/rdf.scm | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index 7bf75eeb28..b297b5209b 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -98,12 +98,7 @@ Java Lucene text search engine API to C++.") (define-public soprano (package (name "soprano") - (version "2.9.3") - ;; 2.9.4 requires clucene, see - ;; http://www.mailinglistarchive.com/html/lfs-book@linuxfromscratch.org/2013-10/msg00285.html - ;; The stable clucene-0.9.21b fails one of its tests; - ;; in the unstable clucene-2.3.3.4 the binary cl_test is not found. - ;; In any case, the library seems to be unmaintained. + (version "2.9.4") (source (origin (method url-fetch) (uri (string-append "mirror://sourceforge/soprano/Soprano/" @@ -111,14 +106,16 @@ Java Lucene text search engine API to C++.") "soprano-" version ".tar.bz2")) (sha256 (base32 - "08gb5d8bgy7vc6qd6r1kkmmc5rli67dlglpjqjlahpnvs26r1cwl")))) + "1rg0x7yg0a1cbnxz7kqk52580wla8jbnj4d4r3j7l7g7ajyny1k4")))) (build-system cmake-build-system) - ;; FIXME: Add optional dependencies: Redland, odbci, clucene + ;; FIXME: Add optional dependencies: Redland, odbci. (native-inputs `(("doxygen" ,doxygen) ("pkg-config" ,pkg-config))) (inputs - `(("qt" ,qt-4) + `(("clucene" ,clucene) ; is not yet "fully found", but sufficiently + ; so to allow for compilation... + ("qt" ,qt-4) ("raptor2" ,raptor2))) (home-page "http://soprano.sourceforge.net/") (synopsis "RDF data library for Qt") -- cgit v1.2.3 From ba948b4fa0a088f42815aa104e651c9d14d8a1ba Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Mon, 28 Apr 2014 20:20:52 +0200 Subject: gnu: soprano: Add input clucene. * gnu/packages/rdf.scm (soprano): Add input clucene and patch the cmake file looking for it. * gnu/packages/patches/soprano-find-clucene.patch: New file. * gnu-system.am (dist_patch_DATA): Register the patch. --- gnu-system.am | 1 + gnu/packages/patches/soprano-find-clucene.patch | 15 +++++++++++++++ gnu/packages/rdf.scm | 6 +++--- 3 files changed, 19 insertions(+), 3 deletions(-) create mode 100644 gnu/packages/patches/soprano-find-clucene.patch diff --git a/gnu-system.am b/gnu-system.am index 3cc946a3ca..c18db0dc56 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -335,6 +335,7 @@ dist_patch_DATA = \ gnu/packages/patches/slim-session.patch \ gnu/packages/patches/slim-config.patch \ gnu/packages/patches/slim-sigusr1.patch \ + gnu/packages/patches/soprano-find-clucene.patch \ gnu/packages/patches/source-highlight-regexrange-test.patch \ gnu/packages/patches/sqlite-large-page-size-fix.patch \ gnu/packages/patches/tcsh-fix-autotest.patch \ diff --git a/gnu/packages/patches/soprano-find-clucene.patch b/gnu/packages/patches/soprano-find-clucene.patch new file mode 100644 index 0000000000..cc2707853a --- /dev/null +++ b/gnu/packages/patches/soprano-find-clucene.patch @@ -0,0 +1,15 @@ +Search for clucene include file in the clucene include directory. + +diff -u -r soprano-2.9.4.orig/cmake/modules/FindCLucene.cmake soprano-2.9.4/cmake/modules/FindCLucene.cmake +--- soprano-2.9.4.orig/cmake/modules/FindCLucene.cmake 2013-10-09 19:22:28.000000000 +0200 ++++ soprano-2.9.4/cmake/modules/FindCLucene.cmake 2014-04-28 20:08:11.000000000 +0200 +@@ -77,7 +77,8 @@ + + get_filename_component(TRIAL_LIBRARY_DIR ${CLUCENE_LIBRARY} PATH) + find_path(CLUCENE_LIBRARY_DIR +- NAMES CLucene/clucene-config.h PATHS ${TRIAL_LIBRARY_DIR} ${TRIAL_LIBRARY_PATHS} ${TRIAL_INCLUDE_PATHS} NO_DEFAULT_PATH) ++ NAMES CLucene/clucene-config.h PATHS ${TRIAL_LIBRARY_DIR} ${TRIAL_LIBRARY_PATHS} ${TRIAL_INCLUDE_PATHS} ${CLUCENE_INCLUDE_DIR} NO_DEFAULT_PATH) ++message (STATUS "XXX ${CLUCENE_LIBRARY_DIR}") + if(CLUCENE_LIBRARY_DIR) + message(STATUS "Found CLucene library dir: ${CLUCENE_LIBRARY_DIR}") + file(READ ${CLUCENE_LIBRARY_DIR}/CLucene/clucene-config.h CLCONTENT) diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index b297b5209b..368245bbaa 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -106,15 +106,15 @@ Java Lucene text search engine API to C++.") "soprano-" version ".tar.bz2")) (sha256 (base32 - "1rg0x7yg0a1cbnxz7kqk52580wla8jbnj4d4r3j7l7g7ajyny1k4")))) + "1rg0x7yg0a1cbnxz7kqk52580wla8jbnj4d4r3j7l7g7ajyny1k4")) + (patches (list (search-patch "soprano-find-clucene.patch"))))) (build-system cmake-build-system) ;; FIXME: Add optional dependencies: Redland, odbci. (native-inputs `(("doxygen" ,doxygen) ("pkg-config" ,pkg-config))) (inputs - `(("clucene" ,clucene) ; is not yet "fully found", but sufficiently - ; so to allow for compilation... + `(("clucene" ,clucene) ("qt" ,qt-4) ("raptor2" ,raptor2))) (home-page "http://soprano.sourceforge.net/") -- cgit v1.2.3 From 21b679f6944f4e1f09f949322f5242b761dc22a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Apr 2014 23:00:57 +0200 Subject: Add (guix gexp). * guix/gexp.scm: New file. * tests/gexp.scm: New file. * Makefile.am (MODULES): Add guix/gexp.scm. (SCM_TESTS): Add tests/gexp.scm. * doc/guix.texi (Derivations): Add #:inputs in 'derivation' example. Mark 'build-expression->derivation' as deprecated, refer to "G-Expressions". Remove paragraph about code strata. (G-Expressions): New node. --- .dir-locals.el | 9 +- Makefile.am | 2 + doc/guix.texi | 219 +++++++++++++++++++++++++++++--- guix/gexp.scm | 391 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/gexp.scm | 234 ++++++++++++++++++++++++++++++++++ 5 files changed, 837 insertions(+), 18 deletions(-) create mode 100644 guix/gexp.scm create mode 100644 tests/gexp.scm diff --git a/.dir-locals.el b/.dir-locals.el index 49380fe4ba..a6135b171e 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -6,6 +6,7 @@ (scheme-mode . ((indent-tabs-mode . nil) + (eval . (put 'eval-when 'scheme-indent-function 1)) (eval . (put 'test-assert 'scheme-indent-function 1)) (eval . (put 'test-equal 'scheme-indent-function 1)) (eval . (put 'test-eq 'scheme-indent-function 1)) @@ -31,7 +32,13 @@ (eval . (put 'with-monad 'scheme-indent-function 1)) (eval . (put 'mlet* 'scheme-indent-function 2)) (eval . (put 'mlet 'scheme-indent-function 2)) - (eval . (put 'run-with-store 'scheme-indent-function 1)))) + (eval . (put 'run-with-store 'scheme-indent-function 1)) + + ;; Recognize '~' and '$', as used for gexps, as quotation symbols. This + ;; notably allows '(' in Paredit to not insert a space when the preceding + ;; symbol is one of these. + (eval . (modify-syntax-entry ?~ "'")) + (eval . (modify-syntax-entry ?$ "'")))) (emacs-lisp-mode . ((indent-tabs-mode . nil))) (texinfo-mode . ((indent-tabs-mode . nil) (fill-column . 72)))) diff --git a/Makefile.am b/Makefile.am index 8d425f1be9..d01032f530 100644 --- a/Makefile.am +++ b/Makefile.am @@ -37,6 +37,7 @@ MODULES = \ guix/download.scm \ guix/git-download.scm \ guix/monads.scm \ + guix/gexp.scm \ guix/profiles.scm \ guix/serialization.scm \ guix/nar.scm \ @@ -139,6 +140,7 @@ SCM_TESTS = \ tests/snix.scm \ tests/store.scm \ tests/monads.scm \ + tests/gexp.scm \ tests/nar.scm \ tests/union.scm \ tests/profiles.scm diff --git a/doc/guix.texi b/doc/guix.texi index f8d71fdace..9fb226c651 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1305,6 +1305,7 @@ package definitions. * The Store:: Manipulating the package store. * Derivations:: Low-level interface to package derivations. * The Store Monad:: Purely functional interface to the store. +* G-Expressions:: Manipulating build expressions. @end menu @node Defining Packages @@ -1762,13 +1763,21 @@ to a Bash executable in the store: "echo hello world > $out\n" '()))) (derivation store "foo" bash `("-e" ,builder) + #:inputs `((,bash) (,builder)) #:env-vars '(("HOME" . "/homeless")))) @result{} # /gnu/store/@dots{}-foo> @end lisp -As can be guessed, this primitive is cumbersome to use directly. An -improved variant is @code{build-expression->derivation}, which allows -the caller to directly pass a Guile expression as the build script: +As can be guessed, this primitive is cumbersome to use directly. A +better approach is to write build scripts in Scheme, of course! The +best course of action for that is to write the build code as a +``G-expression'', and to pass it to @code{gexp->derivation}. For more +information, @ref{G-Expressions}. + +Once upon a time, @code{gexp->derivation} did not exist and constructing +derivations with build code written in Scheme was achieved with +@code{build-expression->derivation}, documented below. This procedure +is now deprecated in favor of the much nicer @code{gexp->derivation}. @deffn {Scheme Procedure} build-expression->derivation @var{store} @ @var{name} @var{exp} @ @@ -1816,20 +1825,6 @@ containing one file: @result{} # @dots{}> @end lisp -@cindex strata of code -Remember that the build expression passed to -@code{build-expression->derivation} is run by a separate Guile process -than the one that calls @code{build-expression->derivation}: it is run -by a Guile process launched by the daemon, typically in a chroot. So, -while there is a single language for both the @dfn{host} and the build -side, there are really two @dfn{strata} of code: the host-side, and the -build-side code@footnote{The term @dfn{stratum} in this context was -coined by Manuel Serrano et al. in the context of their work on Hop.}. -This distinction is important to keep in mind, notably when using -higher-level constructs such as @var{gnu-build-system} (@pxref{Defining -Packages}). For this reason, Guix modules that are meant to be used in -the build stratum are kept in the @code{(guix build @dots{})} name -space. @node The Store Monad @section The Store Monad @@ -1993,6 +1988,196 @@ Packages}). @end deffn +@node G-Expressions +@section G-Expressions + +@cindex G-expression +@cindex build code quoting +So we have ``derivations'', which represent a sequence of build actions +to be performed to produce an item in the store (@pxref{Derivations}). +Those build actions are performed when asking the daemon to actually +build the derivations; they are run by the daemon in a container +(@pxref{Invoking guix-daemon}). + +@cindex strata of code +It should come as no surprise that we like to write those build actions +in Scheme. When we do that, we end up with two @dfn{strata} of Scheme +code@footnote{The term @dfn{stratum} in this context was coined by +Manuel Serrano et al.@: in the context of their work on Hop.}: the +``host code''---code that defines packages, talks to the daemon, +etc.---and the ``build code''---code that actually performs build +actions, such as making directories, invoking @command{make}, etc. + +To describe a derivation and its build actions, one typically needs to +embed build code inside host code. It boils down to manipulating build +code as data, and Scheme's homoiconicity---code has a direct +representation as data---comes in handy for that. But we need more than +Scheme's normal @code{quasiquote} mechanism to construct build +expressions. + +The @code{(guix gexp)} module implements @dfn{G-expressions}, a form of +S-expressions adapted to build expressions. G-expressions, or +@dfn{gexps}, consist essentially in three syntactic forms: @code{gexp}, +@code{ungexp}, and @code{ungexp-splicing} (or simply: @code{#~}, +@code{#$}, and @code{#$@@}), which are comparable respectively to +@code{quasiquote}, @code{unquote}, and @code{unquote-splicing} +(@pxref{Expression Syntax, @code{quasiquote},, guile, GNU Guile +Reference Manual}). However, there are major differences: + +@itemize +@item +Gexps are meant to be written to a file and run or manipulated by other +processes. + +@item +When a package or derivation is unquoted inside a gexp, the result is as +if its output file name had been introduced. + +@item +Gexps carry information about the packages or derivations they refer to, +and these dependencies are automatically added as inputs to the build +processes that use them. +@end itemize + +To illustrate the idea, here is an example of a gexp: + +@example +(define build-exp + #~(begin + (mkdir #$output) + (chdir #$output) + (symlink (string-append #$coreutils "/bin/ls") + "list-files"))) +@end example + +This gexp can be passed to @code{gexp->derivation}; we obtain a +derivation that builds a directory containing exactly one symlink to +@file{/gnu/store/@dots{}-coreutils-8.22/bin/ls}: + +@example +(gexp->derivation "the-thing" build-exp) +@end example + +As one would expect, the @code{"/gnu/store/@dots{}-coreutils"} string is +substituted to the reference to the @var{coreutils} package in the +actual build code, and @var{coreutils} is automatically made an input to +the derivation. Likewise, @code{#$output} (equivalent to @code{(ungexp +output)}) is replaced by a string containing the derivation's output +directory name. The syntactic form to construct gexps is summarized +below. + +@deffn {Scheme Syntax} #~@var{exp} +@deffnx {Scheme Syntax} (gexp @var{exp}) +Return a G-expression containing @var{exp}. @var{exp} may contain one +or more of the following forms: + +@table @code +@item #$@var{obj} +@itemx (ungexp @var{obj}) +Introduce a reference to @var{obj}. @var{obj} may be a package or a +derivation, in which case the @code{ungexp} form is replaced by its +output file name---e.g., @code{"/gnu/store/@dots{}-coreutils-8.22}. + +If @var{obj} is a list, it is traversed and any package or derivation +references are substituted similarly. + +If @var{obj} is another gexp, its contents are inserted and its +dependencies are added to those of the containing gexp. + +If @var{obj} is another kind of object, it is inserted as is. + +@item #$@var{package-or-derivation}:@var{output} +@itemx (ungexp @var{package-or-derivation} @var{output}) +This is like the form above, but referring explicitly to the +@var{output} of @var{package-or-derivation}---this is useful when +@var{package-or-derivation} produces multiple outputs (@pxref{Packages +with Multiple Outputs}). + +@item #$output[:@var{output}] +@itemx (ungexp output [@var{output}]) +Insert a reference to derivation output @var{output}, or to the main +output when @var{output} is omitted. + +This only makes sense for gexps passed to @code{gexp->derivation}. + +@item #$@@@var{lst} +@itemx (ungexp-splicing @var{lst}) +Like the above, but splices the contents of @var{lst} inside the +containing list. + +@end table + +G-expressions created by @code{gexp} or @code{#~} are run-time objects +of the @code{gexp?} type (see below.) +@end deffn + +@deffn {Scheme Procedure} gexp? @var{obj} +Return @code{#t} if @var{obj} is a G-expression. +@end deffn + +G-expressions are meant to be written to disk, either as code building +some derivation, or as plain files in the store. The monadic procedures +below allow you to do that (@pxref{The Store Monad}, for more +information about monads.) + +@deffn {Monadic Procedure} gexp->derivation @var{name} @var{exp} @ + [#:system (%current-system)] [#:inputs '()] @ + [#:hash #f] [#:hash-algo #f] @ + [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ + [#:references-graphs #f] [#:local-build? #f] @ + [#:guile-for-build #f] +Return a derivation @var{name} that runs @var{exp} (a gexp) with +@var{guile-for-build} (a derivation) on @var{system}. + +Make @var{modules} available in the evaluation context of @var{EXP}; +@var{MODULES} is a list of names of Guile modules from the current +search path to be copied in the store, compiled, and made available in +the load path during the execution of @var{exp}---e.g., @code{((guix +build utils) (guix build gnu-build-system))}. + +The other arguments are as for @code{derivation}. +@end deffn + +@deffn {Monadic Procedure} gexp->script @var{name} @var{exp} +Return an executable script @var{name} that runs @var{exp} using +@var{guile} with @var{modules} in its search path. + +The example below builds a script that simply invokes the @command{ls} +command: + +@example +(use-modules (guix gexp) (gnu packages base)) + +(gexp->script "list-files" + #~(execl (string-append #$coreutils "/bin/ls") + "ls")) +@end example + +When ``running'' it through the store (@pxref{The Store Monad, +@code{run-with-store}}), we obtain a derivation that procedures an +executable file @file{/gnu/store/@dots{}-list-files} along these lines: + +@example +#!/gnu/store/@dots{}-guile-2.0.11/bin/guile -ds +!# +(execl (string-append "/gnu/store/@dots{}-coreutils-8.22"/bin/ls") + "ls") +@end example +@end deffn + +@deffn {Monadic Procedure} gexp->file @var{name} @var{exp} +Return a derivation that builds a file @var{name} containing @var{exp}. + +The resulting file holds references to all the dependencies of @var{exp} +or a subset thereof. +@end deffn + +Of course, in addition to gexps embedded in ``host'' code, there are +also modules containing build tools. To make it clear that they are +meant to be used in the build stratum, these modules are kept in the +@code{(guix build @dots{})} name space. + + @c ********************************************************************* @node Utilities @chapter Utilities diff --git a/guix/gexp.scm b/guix/gexp.scm new file mode 100644 index 0000000000..9dd83f5370 --- /dev/null +++ b/guix/gexp.scm @@ -0,0 +1,391 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix gexp) + #:use-module ((guix store) + #:select (direct-store-path?)) + #:use-module (guix monads) + #:use-module ((guix derivations) + #:select (derivation? derivation->output-path + %guile-for-build derivation)) + #:use-module (guix packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (gexp + gexp? + gexp->derivation + gexp->file + gexp->script)) + +;;; Commentary: +;;; +;;; This module implements "G-expressions", or "gexps". Gexps are like +;;; S-expressions (sexps), with two differences: +;;; +;;; 1. References (un-quotations) to derivations or packages in a gexp are +;;; replaced by the corresponding output file name; +;;; +;;; 2. Gexps embed information about the derivations they refer to. +;;; +;;; Gexps make it easy to write to files Scheme code that refers to store +;;; items, or to write Scheme code to build derivations. +;;; +;;; Code: + +;; "G expressions". +(define-record-type + (make-gexp references proc) + gexp? + (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) + (proc gexp-proc)) ; procedure + +;; Reference to one of the derivation's outputs, for gexps used in +;; derivations. +(define-record-type + (output-ref name) + output-ref? + (name output-ref-name)) + +(define raw-derivation + (store-lift derivation)) + +(define (lower-inputs* inputs) + "Turn any package from INPUTS into a derivation; return the corresponding +input list as a monadic value." + ;; XXX: This is like 'lower-inputs' but without the "name" part in tuples. + (with-monad %store-monad + (sequence %store-monad + (map (match-lambda + (((? package? package) sub-drv ...) + (mlet %store-monad ((drv (package->derivation package))) + (return `(,drv ,@sub-drv)))) + (input + (return input))) + inputs)))) + +(define* (gexp->derivation name exp + #:key + (system (%current-system)) + hash hash-algo recursive? + (env-vars '()) + (modules '()) + (guile-for-build (%guile-for-build)) + references-graphs + local-build?) + "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a +derivation) on SYSTEM. + +Make MODULES available in the evaluation context of EXP; MODULES is a list of +names of Guile modules from the current search path to be copied in the store, +compiled, and made available in the load path during the execution of +EXP---e.g., '((guix build utils) (guix build gnu-build-system)). + +The other arguments are as for 'derivation'." + (define %modules modules) + (define outputs (gexp-outputs exp)) + + (mlet* %store-monad ((inputs (lower-inputs* (gexp-inputs exp))) + (sexp (gexp->sexp exp #:outputs outputs)) + (builder (text-file (string-append name "-builder") + (object->string sexp))) + (modules (if (pair? %modules) + (imported-modules %modules + #:system system + #:guile guile-for-build) + (return #f))) + (compiled (if (pair? %modules) + (compiled-modules %modules + #:system system + #:guile guile-for-build) + (return #f))) + (guile (if guile-for-build + (return guile-for-build) + (package->derivation + (@ (gnu packages base) guile-final) + system)))) + (raw-derivation name + (string-append (derivation->output-path guile) + "/bin/guile") + `("--no-auto-compile" + ,@(if (pair? %modules) + `("-L" ,(derivation->output-path modules) + "-C" ,(derivation->output-path compiled)) + '()) + ,builder) + #:outputs outputs + #:env-vars env-vars + #:system system + #:inputs `((,guile) + (,builder) + ,@(if modules + `((,modules) (,compiled) ,@inputs) + inputs)) + #:hash hash #:hash-algo hash-algo #:recursive? recursive? + #:references-graphs references-graphs + #:local-build? local-build?))) + +(define (gexp-inputs exp) + "Return the input list for EXP." + (define (add-reference-inputs ref result) + (match ref + (((? derivation?) (? string?)) + (cons ref result)) + (((? package?) (? string?)) + (cons ref result)) + ((? gexp? exp) + (append (gexp-inputs exp) result)) + (((? string? file)) + (if (direct-store-path? file) + (cons ref result) + result)) + ((refs ...) + (fold-right add-reference-inputs result refs)) + (_ + ;; Ignore references to other kinds of objects. + result))) + + (fold-right add-reference-inputs + '() + (gexp-references exp))) + +(define (gexp-outputs exp) + "Return the outputs referred to by EXP as a list of strings." + (define (add-reference-output ref result) + (match ref + (($ name) + (cons name result)) + ((? gexp? exp) + (append (gexp-outputs exp) result)) + (_ + result))) + + (fold-right add-reference-output + '() + (gexp-references exp))) + +(define* (gexp->sexp exp #:key (outputs '())) + "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, +and in the current monad setting (system type, etc.)" + (define (reference->sexp ref) + (with-monad %store-monad + (match ref + (((? derivation? drv) (? string? output)) + (return (derivation->output-path drv output))) + (((? package? p) (? string? output)) + (package-file p #:output output)) + (($ output) + (match (member output outputs) + (#f + (error "no such output" output)) + (_ + (return `((@ (guile) getenv) ,output))))) + ((? gexp? exp) + (gexp->sexp exp #:outputs outputs)) + (((? string? str)) + (return (if (direct-store-path? str) str ref))) + ((refs ...) + (sequence %store-monad (map reference->sexp refs))) + (x + (return x))))) + + (mlet %store-monad + ((args (sequence %store-monad + (map reference->sexp (gexp-references exp))))) + (return (apply (gexp-proc exp) args)))) + +(define (canonicalize-reference ref) + "Return a canonical variant of REF, which adds any missing output part in +package/derivation references." + (match ref + ((? package? p) + `(,p "out")) + ((? derivation? d) + `(,d "out")) + (((? package?) (? string?)) + ref) + (((? derivation?) (? string?)) + ref) + ((? string? s) + (if (direct-store-path? s) `(,s) s)) + ((refs ...) + (map canonicalize-reference refs)) + (x x))) + +(define (syntax-location-string s) + "Return a string representing the source code location of S." + (let ((props (syntax-source s))) + (if props + (let ((file (assoc-ref props 'filename)) + (line (and=> (assoc-ref props 'line) 1+)) + (column (assoc-ref props 'column))) + (if file + (simple-format #f "~a:~a:~a" + file line column) + (simple-format #f "~a:~a" line column))) + ""))) + +(define-syntax gexp + (lambda (s) + (define (collect-escapes exp) + ;; Return all the 'ungexp' present in EXP. + (let loop ((exp exp) + (result '())) + (syntax-case exp (ungexp ungexp-splicing) + ((ungexp _) + (cons exp result)) + ((ungexp _ _) + (cons exp result)) + ((ungexp-splicing _ ...) + (cons exp result)) + ((exp0 exp ...) + (let ((result (loop #'exp0 result))) + (fold loop result #'(exp ...)))) + (_ + result)))) + + (define (escape->ref exp) + ;; Turn 'ungexp' form EXP into a "reference". + (syntax-case exp (ungexp ungexp-splicing output) + ((ungexp output) + #'(output-ref "out")) + ((ungexp output name) + #'(output-ref name)) + ((ungexp thing) + #'thing) + ((ungexp drv-or-pkg out) + #'(list drv-or-pkg out)) + ((ungexp-splicing lst) + #'lst))) + + (define (substitute-references exp substs) + ;; Return a variant of EXP where all the cars of SUBSTS have been + ;; replaced by the corresponding cdr. + (syntax-case exp (ungexp ungexp-splicing) + ((ungexp _ ...) + (match (assoc exp substs) + ((_ id) + id) + (_ + #'(syntax-error "error: no 'ungexp' substitution" + #'ref)))) + (((ungexp-splicing _ ...) rest ...) + (syntax-case exp () + ((exp rest ...) + (match (assoc #'exp substs) + ((_ id) + (with-syntax ((id id)) + #`(append id + #,(substitute-references #'(rest ...) substs)))) + (_ + #'(syntax-error "error: no 'ungexp-splicing' substitution" + #'ref)))))) + ((exp0 exp ...) + #`(cons #,(substitute-references #'exp0 substs) + #,(substitute-references #'(exp ...) substs))) + (x #''x))) + + (syntax-case s (ungexp output) + ((_ exp) + (let* ((escapes (delete-duplicates (collect-escapes #'exp))) + (formals (generate-temporaries escapes)) + (sexp (substitute-references #'exp (zip escapes formals))) + (refs (map escape->ref escapes))) + #`(make-gexp (map canonicalize-reference (list #,@refs)) + (lambda #,formals + #,sexp))))))) + + +;;; +;;; Convenience procedures. +;;; + +(define* (gexp->script name exp + #:key (modules '()) + (guile (@ (gnu packages base) guile-final))) + "Return an executable script NAME that runs EXP using GUILE with MODULES in +its search path." + (mlet %store-monad ((modules (imported-modules modules)) + (compiled (compiled-modules modules))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (format port + "#!~a/bin/guile --no-auto-compile~%!#~%" + (ungexp guile)) + (write + '(set! %load-path + (cons (ungexp modules) %load-path)) + port) + (write + '(set! %load-compiled-path + (cons (ungexp compiled) + %load-compiled-path)) + port) + (write '(ungexp exp) port) + (chmod port #o555))))))) + +(define (gexp->file name exp) + "Return a derivation that builds a file NAME containing EXP." + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp exp) port)))))) + + + +;;; +;;; Syntactic sugar. +;;; + +(eval-when (expand load eval) + (define (read-ungexp chr port) + "Read an 'ungexp' or 'ungexp-splicing' form from PORT." + (define unquote-symbol + (match (peek-char port) + (#\@ + (read-char port) + 'ungexp-splicing) + (_ + 'ungexp))) + + (match (read port) + ((? symbol? symbol) + (let ((str (symbol->string symbol))) + (match (string-index-right str #\:) + (#f + `(,unquote-symbol ,symbol)) + (colon + (let ((name (string->symbol (substring str 0 colon))) + (output (substring str (+ colon 1)))) + `(,unquote-symbol ,name ,output)))))) + (x + `(,unquote-symbol ,x)))) + + (define (read-gexp chr port) + "Read a 'gexp' form from PORT." + `(gexp ,(read port))) + + ;; Extend the reader + (read-hash-extend #\~ read-gexp) + (read-hash-extend #\$ read-ungexp)) + +;;; gexp.scm ends here diff --git a/tests/gexp.scm b/tests/gexp.scm new file mode 100644 index 0000000000..3da5b82e4c --- /dev/null +++ b/tests/gexp.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix gexp) + #:use-module (guix derivations) + #:use-module ((guix packages) + #:select (package-derivation %current-system)) + #:use-module (gnu packages) + #:use-module (gnu packages base) + #:use-module (gnu packages bootstrap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 popen)) + +;; Test the (guix gexp) module. + +(define %store + (open-connection)) + +;; For white-box testing. +(define gexp-inputs (@@ (guix gexp) gexp-inputs)) +(define gexp->sexp (@@ (guix gexp) gexp->sexp)) + +(define guile-for-build + (package-derivation %store %bootstrap-guile)) + +;; Make it the default. +(%guile-for-build guile-for-build) + +(define (gexp->sexp* exp) + (run-with-store %store (gexp->sexp exp) + #:guile-for-build guile-for-build)) + +(define-syntax-rule (test-assertm name exp) + (test-assert name + (run-with-store %store exp + #:guile-for-build guile-for-build))) + + +(test-begin "gexp") + +(test-equal "no refs" + '(display "hello!") + (let ((exp (gexp (display "hello!")))) + (and (gexp? exp) + (null? (gexp-inputs exp)) + (gexp->sexp* exp)))) + +(test-equal "unquote" + '(display `(foo ,(+ 2 3))) + (let ((exp (gexp (display `(foo ,(+ 2 3)))))) + (and (gexp? exp) + (null? (gexp-inputs exp)) + (gexp->sexp* exp)))) + +(test-assert "one input package" + (let ((exp (gexp (display (ungexp coreutils))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((p "out")) + (eq? p coreutils))) + (equal? `(display ,(derivation->output-path + (package-derivation %store coreutils))) + (gexp->sexp* exp))))) + +(test-assert "same input twice" + (let ((exp (gexp (begin + (display (ungexp coreutils)) + (display (ungexp coreutils)))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((p "out")) + (eq? p coreutils))) + (let ((e `(display ,(derivation->output-path + (package-derivation %store coreutils))))) + (equal? `(begin ,e ,e) (gexp->sexp* exp)))))) + +(test-assert "two input packages, one derivation, one file" + (let* ((drv (build-expression->derivation + %store "foo" 'bar + #:guile-for-build (package-derivation %store %bootstrap-guile))) + (txt (add-text-to-store %store "foo" "Hello, world!")) + (exp (gexp (begin + (display (ungexp coreutils)) + (display (ungexp %bootstrap-guile)) + (display (ungexp drv)) + (display (ungexp txt)))))) + (define (match-input thing) + (match-lambda + ((drv-or-pkg _ ...) + (eq? thing drv-or-pkg)))) + + (and (gexp? exp) + (= 4 (length (gexp-inputs exp))) + (every (lambda (input) + (find (match-input input) (gexp-inputs exp))) + (list drv coreutils %bootstrap-guile txt)) + (let ((e0 `(display ,(derivation->output-path + (package-derivation %store coreutils)))) + (e1 `(display ,(derivation->output-path + (package-derivation %store %bootstrap-guile)))) + (e2 `(display ,(derivation->output-path drv))) + (e3 `(display ,txt))) + (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp)))))) + +(test-assert "input list" + (let ((exp (gexp (display + '(ungexp (list %bootstrap-guile coreutils))))) + (guile (derivation->output-path + (package-derivation %store %bootstrap-guile))) + (cu (derivation->output-path + (package-derivation %store coreutils)))) + (and (lset= equal? + `((,%bootstrap-guile "out") (,coreutils "out")) + (gexp-inputs exp)) + (equal? `(display '(,guile ,cu)) + (gexp->sexp* exp))))) + +(test-assert "input list splicing" + (let* ((inputs (list (list glibc "debug") %bootstrap-guile)) + (outputs (list (derivation->output-path + (package-derivation %store glibc) + "debug") + (derivation->output-path + (package-derivation %store %bootstrap-guile)))) + (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) + (and (lset= equal? + `((,glibc "debug") (,%bootstrap-guile "out")) + (gexp-inputs exp)) + (equal? (gexp->sexp* exp) + `(list ,@(cons 5 outputs)))))) + +(test-assertm "gexp->file" + (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile)))) + (guile (package-file %bootstrap-guile)) + (sexp (gexp->sexp exp)) + (drv (gexp->file "foo" exp)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv))) + (refs ((store-lift references) out))) + (return (and (equal? sexp (call-with-input-file out read)) + (equal? (list guile) refs))))) + +(test-assertm "gexp->derivation" + (mlet* %store-monad ((file (text-file "foo" "Hello, world!")) + (exp -> (gexp + (begin + (mkdir (ungexp output)) + (chdir (ungexp output)) + (symlink + (string-append (ungexp %bootstrap-guile) + "/bin/guile") + "foo") + (symlink (ungexp file) + (ungexp output "2nd"))))) + (drv (gexp->derivation "foo" exp)) + (out -> (derivation->output-path drv)) + (out2 -> (derivation->output-path drv "2nd")) + (done (built-derivations (list drv))) + (refs ((store-lift references) out)) + (refs2 ((store-lift references) out2)) + (guile (package-file %bootstrap-guile "bin/guile"))) + (return (and (string=? (readlink (string-append out "/foo")) guile) + (string=? (readlink out2) file) + (equal? refs (list (dirname (dirname guile)))) + (equal? refs2 (list file)))))) + +(test-assertm "gexp->derivation, composed gexps" + (mlet* %store-monad ((exp0 -> (gexp (begin + (mkdir (ungexp output)) + (chdir (ungexp output))))) + (exp1 -> (gexp (symlink + (string-append (ungexp %bootstrap-guile) + "/bin/guile") + "foo"))) + (exp -> (gexp (begin (ungexp exp0) (ungexp exp1)))) + (drv (gexp->derivation "foo" exp)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv))) + (guile (package-file %bootstrap-guile "bin/guile"))) + (return (string=? (readlink (string-append out "/foo")) + guile)))) + +(test-assertm "gexp->script" + (mlet* %store-monad ((n -> (random (expt 2 50))) + (exp -> (gexp + (system* + (string-append (ungexp %bootstrap-guile) + "/bin/guile") + "-c" (object->string + '(display (expt (ungexp n) 2)))))) + (drv (gexp->script "guile-thing" exp + #:guile %bootstrap-guile)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv)))) + (let* ((pipe (open-input-pipe out)) + (str (get-string-all pipe))) + (return (and (zero? (close-pipe pipe)) + (= (expt n 2) (string->number str))))))) + +(test-equal "sugar" + '(gexp (foo (ungexp bar) (ungexp baz "out") + (ungexp (chbouib 42)) + (ungexp-splicing (list x y z)))) + '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z))) + +(test-end "gexp") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;; Local Variables: +;; eval: (put 'test-assertm 'scheme-indent-function 1) +;; End: -- cgit v1.2.3 From 02100028bb78b9bb17764eab0f009fd6fa07fd7b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 26 Apr 2014 16:36:48 +0200 Subject: gnu: Use gexps in obvious places in (gnu system ...). * gnu/system.scm (operating-system-boot-script): Use 'gexp->file' instead of 'text-file*'. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Likewise. (system-qemu-image/shared-store-script)[builder]: Turn into a gexp. Use 'gexp->derivation' instead of 'derivation-expression'. --- gnu/system.scm | 8 ++++---- gnu/system/vm.scm | 60 ++++++++++++++++++++++--------------------------------- 2 files changed, 28 insertions(+), 40 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index 93858e972a..6308867794 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -19,6 +19,7 @@ (define-module (gnu system) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix records) #:use-module (guix packages) #:use-module (guix derivations) @@ -333,10 +334,9 @@ we're running in the final root." (etc (operating-system-etc-directory os)) (dmd-conf (dmd-configuration-file services (derivation->output-path etc)))) - ;; FIXME: Use 'sexp-file' or similar. - (text-file* "boot" - "(execl \"" dmd "/bin/dmd\" \"dmd\" - \"--config\" \"" dmd-conf "\")"))) + (gexp->file "boot" + #~(execl (string-append #$dmd "/bin/dmd") + "dmd" "--config" #$dmd-conf)))) (define (operating-system-derivation os) "Return a derivation that builds OS." diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index c491336ccb..82f9ec9a12 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -19,6 +19,7 @@ (define-module (gnu system vm) #:use-module (guix config) #:use-module (guix store) + #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix monads) @@ -158,12 +159,14 @@ made available under the /xchg CIFS share." ,exp)) (user-builder (text-file "builder-in-linux-vm" (object->string exp*))) - (loader (text-file* "linux-vm-loader" ; XXX: use 'sexp-file' - "(begin (set! %load-path (cons \"" - module-dir "\" %load-path)) " - "(set! %load-compiled-path (cons \"" - compiled "\" %load-compiled-path))" - "(primitive-load \"" user-builder "\"))")) + (loader (gexp->file "linux-vm-loader" + #~(begin + (set! %load-path + (cons #$module-dir %load-path)) + (set! %load-compiled-path + (cons #$compiled + %load-compiled-path)) + (primitive-load #$user-builder)))) (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) (initrd (if initrd ; use the default initrd? (return initrd) @@ -351,37 +354,22 @@ OS that shares its store with the host." (initrd initrd) (image (system-qemu-image/shared-store os))) (define builder - (mlet %store-monad ((qemu (package-file qemu - "bin/qemu-system-x86_64")) - (bash (package-file bash "bin/sh")) - (kernel (package-file (operating-system-kernel os) - "bzImage"))) - (return `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (display - (string-append "#!" ,bash " -exec " ,qemu " -enable-kvm -no-reboot -net nic,model=virtio \ - -virtfs local,path=" ,(%store-prefix) ",security_model=none,mount_tag=store \ + #~(call-with-output-file #$output + (lambda (port) + (display + (string-append "#!" #$bash "/bin/sh +exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=virtio \ + -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \ -net user \ - -kernel " ,kernel " -initrd " - ,(string-append (derivation->output-path initrd) "/initrd") " \ --append \"" ,(if graphic? "" "console=ttyS0 ") -"--load=" ,(derivation->output-path os-drv) "/boot --root=/dev/vda1\" \ - -drive file=" ,(derivation->output-path image) + -kernel " #$(operating-system-kernel os) "/bzImage \ + -initrd " #$initrd "/initrd \ +-append \"" #$(if graphic? "" "console=ttyS0 ") + "--load=" #$os-drv "/boot --root=/dev/vda1\" \ + -drive file=" #$image ",if=virtio,cache=writeback,werror=report,readonly\n") - port))) - (chmod out #o555) - #t)))) - - (mlet %store-monad ((qemu (package->derivation qemu)) - (bash (package->derivation bash)) - (builder builder)) - (derivation-expression "run-vm.sh" builder - #:inputs `(("qemu" ,qemu) - ("image" ,image) - ("bash" ,bash) - ("initrd" ,initrd) - ("os" ,os-drv)))))) + port) + (chmod port #o555)))) + + (gexp->derivation "run-vm.sh" builder))) ;;; vm.scm ends here -- cgit v1.2.3 From eee212710978fb2044d3312aff0bf33b508aa026 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 26 Apr 2014 16:38:38 +0200 Subject: store: (direct-store-path? (%store-prefix)) returns #f. * guix/store.scm (direct-store-path?): Return #f if PATH is (%store-prefix). * tests/store.scm ("direct-store-path?"): Add test. --- guix/store.scm | 1 + tests/store.scm | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/guix/store.scm b/guix/store.scm index c1898c5c81..2b924db213 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -839,6 +839,7 @@ be used internally by the daemon's build hook." This predicate is sometimes needed because files *under* a store path are not valid inputs." (and (store-path? path) + (not (string=? path (%store-prefix))) (let ((len (+ 1 (string-length (%store-prefix))))) (not (string-index (substring path len) #\/))))) diff --git a/tests/store.scm b/tests/store.scm index 90137b9754..b0f609f818 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -85,7 +85,8 @@ (not (direct-store-path? (string-append (%store-prefix) - "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile"))))) + "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile"))) + (not (direct-store-path? (%store-prefix))))) (test-skip (if %store 0 13)) -- cgit v1.2.3 From 1aa0033b646b59e62d6a05716a21c631fca55c77 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 14:58:15 +0200 Subject: vm: Rewrite support procedures to use gexps. * gnu/system/vm.scm (%imported-modules): Remove. (expression->derivation-in-linux-vm): Remove 'inputs' parameter. Rename 'imported-modules' to 'modules'. Rewrite using gexps and 'gexp->derivation'. (qemu-image): Add 'qemu' parameter. Pass NAME to 'expression->derivation-in-linux-vm'. Rewrite using gexps. Remove #:inputs argument to 'expression->derivation-in-linux-vm'. (operating-system-default-contents): Rewrite using gexps. * gnu/system.scm (operating-system-profile-derivation): Rename to... (operating-system-profile): ... this. Adjust callers. (operating-system-profile-directory): Remove. --- gnu/system.scm | 15 ++-- gnu/system/vm.scm | 212 +++++++++++++++++++++++------------------------------- 2 files changed, 96 insertions(+), 131 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index 6308867794..65b524d387 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -52,8 +52,8 @@ operating-system-locale operating-system-services - operating-system-profile-directory - operating-system-derivation)) + operating-system-derivation + operating-system-profile)) ;;; Commentary: ;;; @@ -282,17 +282,12 @@ alias ll='ls -l' ("tzdata" ,tzdata)) #:name "etc"))) -(define (operating-system-profile-derivation os) +(define (operating-system-profile os) "Return a derivation that builds the default profile of OS." ;; TODO: Replace with a real profile with a manifest. (union (operating-system-packages os) #:name "default-profile")) -(define (operating-system-profile-directory os) - "Return the directory name of the default profile of OS." - (mlet %store-monad ((drv (operating-system-profile-derivation os))) - (return (derivation->output-path drv)))) - (define (operating-system-accounts os) "Return the user accounts for OS, including an obligatory 'root' account." (mlet %store-monad ((services (sequence %store-monad @@ -317,7 +312,7 @@ alias ll='ls -l' (cons %pam-other-services (append-map service-pam-services services)))) (accounts (operating-system-accounts os)) - (profile-drv (operating-system-profile-derivation os)) + (profile-drv (operating-system-profile os)) (groups -> (append (operating-system-groups os) (append-map service-user-groups services)))) (etc-directory #:accounts accounts #:groups groups @@ -341,7 +336,7 @@ we're running in the final root." (define (operating-system-derivation os) "Return a derivation that builds OS." (mlet* %store-monad - ((profile-drv (operating-system-profile-derivation os)) + ((profile-drv (operating-system-profile os)) (profile -> (derivation->output-path profile-drv)) (etc-drv (operating-system-etc-directory os)) (etc -> (derivation->output-path etc-drv)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 82f9ec9a12..db24c4e761 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -82,18 +82,14 @@ input tuple. The output file name is when building for SYSTEM." ((input (and (? string?) (? store-path?) file)) (return `(,input . ,file)))))) -;; An alias to circumvent name clashes. -(define %imported-modules imported-modules) - (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) - (inputs '()) (linux linux-libre) initrd (qemu qemu-headless) (env-vars '()) - (imported-modules + (modules '((guix build vm) (guix build linux-initrd) (guix build utils))) @@ -106,7 +102,7 @@ input tuple. The output file name is when building for SYSTEM." (disk-image-size (* 100 (expt 2 20)))) "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a -derivation). In the virtual machine, EXP has access to all of INPUTS from the +derivation). In the virtual machine, EXP has access to all its inputs from the store; it should put its output files in the `/xchg' directory, which is copied to the derivation's output when the VM terminates. The virtual machine runs with MEMORY-SIZE MiB of memory. @@ -114,51 +110,15 @@ runs with MEMORY-SIZE MiB of memory. When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of DISK-IMAGE-SIZE bytes and return it. -IMPORTED-MODULES is the set of modules imported in the execution environment -of EXP. +MODULES is the set of modules imported in the execution environment of EXP. 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: Add #:modules parameter, for the 'use-modules' form. - - (define input-alist - (map input->name+output inputs)) - - (define builder - ;; Code that launches the VM that evaluates EXP. - `(let () - (use-modules (guix build utils) - (guix build vm)) - - (let ((linux (string-append (assoc-ref %build-inputs "linux") - "/bzImage")) - (initrd (string-append (assoc-ref %build-inputs "initrd") - "/initrd")) - (loader (assoc-ref %build-inputs "loader")) - (graphs ',(match references-graphs - (((graph-files . _) ...) graph-files) - (_ #f)))) - - (set-path-environment-variable "PATH" '("bin") - (map cdr %build-inputs)) - - (load-in-linux-vm loader - #:output (assoc-ref %outputs "out") - #:linux linux #:initrd initrd - #:memory-size ,memory-size - #:make-disk-image? ,make-disk-image? - #:disk-image-size ,disk-image-size - #:references-graphs graphs)))) - (mlet* %store-monad - ((input-alist (sequence %store-monad input-alist)) - (module-dir (%imported-modules imported-modules)) - (compiled (compiled-modules imported-modules)) - (exp* -> `(let ((%build-inputs ',input-alist)) - ,exp)) - (user-builder (text-file "builder-in-linux-vm" - (object->string exp*))) + ((module-dir (imported-modules modules)) + (compiled (compiled-modules modules)) + (user-builder (gexp->file "builder-in-linux-vm" exp)) (loader (gexp->file "linux-vm-loader" #~(begin (set! %load-path @@ -172,35 +132,50 @@ made available under the /xchg CIFS share." (return initrd) (qemu-initrd #:guile-modules-in-chroot? #t #:mounts `((9p "store" ,(%store-prefix)) - (9p "xchg" "/xchg"))))) - (inputs (lower-inputs `(("qemu" ,qemu) - ("linux" ,linux) - ("initrd" ,initrd) - ("coreutils" ,coreutils) - ("builder" ,user-builder) - ("loader" ,loader) - ,@inputs)))) - (derivation-expression name builder - ;; TODO: Require the "kvm" feature. - #:system system - #:inputs inputs - #:env-vars env-vars - #:modules (delete-duplicates - `((guix build utils) - (guix build vm) - (guix build linux-initrd) - ,@imported-modules)) - #:guile-for-build guile-for-build - #:references-graphs references-graphs))) + (9p "xchg" "/xchg")))))) + + (define builder + ;; Code that launches the VM that evaluates EXP. + #~(begin + (use-modules (guix build utils) + (guix build vm)) + + (let ((inputs '#$(list qemu coreutils)) + (linux (string-append #$linux "/bzImage")) + (initrd (string-append #$initrd "/initrd")) + (loader #$loader) + (graphs '#$(match references-graphs + (((graph-files . _) ...) graph-files) + (_ #f)))) + + (set-path-environment-variable "PATH" '("bin") inputs) + + (load-in-linux-vm loader + #:output #$output + #:linux linux #:initrd initrd + #:memory-size #$memory-size + #:make-disk-image? #$make-disk-image? + #:disk-image-size #$disk-image-size + #:references-graphs graphs)))) + + (gexp->derivation name builder + ;; TODO: Require the "kvm" feature. + #:system system + #:env-vars env-vars + #:modules `((guix build utils) + (guix build vm) + (guix build linux-initrd)) + #:guile-for-build guile-for-build + #:references-graphs references-graphs))) (define* (qemu-image #:key (name "qemu-image") (system (%current-system)) + (qemu qemu-headless) (disk-image-size (* 100 (expt 2 20))) grub-configuration (initialize-store? #f) (populate #f) - (inputs '()) (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 @@ -218,41 +193,37 @@ such as /etc files." ((graph (sequence %store-monad (map input->name+output inputs-to-copy)))) (expression->derivation-in-linux-vm - "qemu-image" - `(let () - (use-modules (guix build vm) - (guix build utils)) - - (set-path-environment-variable "PATH" '("bin" "sbin") - (map cdr %build-inputs)) - - (let ((graphs ',(match inputs-to-copy - (((names . _) ...) - names)))) - (initialize-hard-disk #:grub.cfg ,grub-configuration - #:closures-to-copy graphs - #:disk-image-size ,disk-image-size - #:initialize-store? ,initialize-store? - #:directives ',populate) - (reboot))) + name + #~(begin + (use-modules (guix build vm) + (guix build utils)) + + (let ((inputs + '#$(append (list qemu parted grub e2fsprogs util-linux) + (map (compose car (cut assoc-ref %final-inputs <>)) + '("sed" "grep" "coreutils" "findutils" "gawk")) + (if initialize-store? (list guix) '()))) + + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-copy + '#$(map (match-lambda + ((name thing) thing) + ((name thing output) `(,thing ,output))) + inputs-to-copy))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + + (let ((graphs '#$(match inputs-to-copy + (((names . _) ...) + names)))) + (initialize-hard-disk #:grub.cfg #$grub-configuration + #:closures-to-copy graphs + #:disk-image-size #$disk-image-size + #:initialize-store? #$initialize-store? + #:directives '#$populate) + (reboot)))) #:system system - #:inputs `(("parted" ,parted) - ("grub" ,grub) - ("e2fsprogs" ,e2fsprogs) - - ;; For shell scripts. - ("sed" ,(car (assoc-ref %final-inputs "sed"))) - ("grep" ,(car (assoc-ref %final-inputs "grep"))) - ("coreutils" ,(car (assoc-ref %final-inputs "coreutils"))) - ("findutils" ,(car (assoc-ref %final-inputs "findutils"))) - ("gawk" ,(car (assoc-ref %final-inputs "gawk"))) - ("util-linux" ,util-linux) - - ,@(if initialize-store? - `(("guix" ,guix)) - '()) - - ,@inputs-to-copy) #:make-disk-image? #t #:disk-image-size disk-image-size #:references-graphs graph))) @@ -283,29 +254,28 @@ basic contents of the root file system of OS." (gid (or (user-account-gid user) 0)) (root (string-append "/var/guix/profiles/per-user/" (user-account-name user)))) - `((directory ,root ,uid ,gid) - (directory ,home ,uid ,gid)))) + #~((directory #$root #$uid #$gid) + (directory #$home #$uid #$gid)))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) (build-gid (operating-system-build-gid os)) - (profile (operating-system-profile-directory os))) - (return `((directory ,(%store-prefix) 0 ,(or build-gid 0)) - (directory "/etc") - (directory "/var/log") ; for dmd - (directory "/var/run/nscd") - (directory "/var/guix/gcroots") - ("/var/guix/gcroots/system" -> ,os-dir) - (directory "/run") - ("/run/current-system" -> ,profile) - (directory "/bin") - ("/bin/sh" -> "/run/current-system/bin/bash") - (directory "/tmp") - (directory "/var/guix/profiles/per-user/root" 0 0) - - (directory "/root" 0 0) ; an exception - ,@(append-map user-directories - (operating-system-users os)))))) + (profile (operating-system-profile os))) + (return #~((directory #$(%store-prefix) 0 #$(or build-gid 0)) + (directory "/etc") + (directory "/var/log") ; for dmd + (directory "/var/run/nscd") + (directory "/var/guix/gcroots") + ("/var/guix/gcroots/system" -> #$os-drv) + (directory "/run") + ("/run/current-system" -> #$profile) + (directory "/bin") + ("/bin/sh" -> "/run/current-system/bin/bash") + (directory "/tmp") + (directory "/var/guix/profiles/per-user/root" 0 0) + + (directory "/root" 0 0) ; an exception + #$@(append-map user-directories + (operating-system-users os)))))) (define* (system-qemu-image os #:key (disk-image-size (* 900 (expt 2 20)))) -- cgit v1.2.3 From b5f4e686359d8842b329e6b161ef89fa6c04ebc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Apr 2014 23:07:08 +0200 Subject: services: Rewrite using gexps. * gnu/services.scm ()[inputs]: Remove. * gnu/system.scm (links): Remove. (etc-directory): Add PASSWD and SHADOW to #:inputs. (operating-system-boot-script): Pass ETC to 'dmd-configuration-file'. (operating-system-derivation): Remove EXTRAS from the union. * gnu/system/linux.scm (pam-service->configuration): Rewrite in terms of 'gexp->derivation'. Compute the contents on the build side. Expect 'arguments' to contain a list of gexps. (pam-services->directory): Rewrite in terms of 'gexp->derivation'. (unix-pam-service): Change 'arguments' to a list of one gexp. * gnu/system/shadow.scm ()[inputs]: Remove. [shell]: Change default value to a gexp. (passwd-file): Rewrite in terms of 'gexp->derivation'. Compute contents on the build side. * gnu/services/base.scm (host-name-service, mingetty-service, nscd-service, syslog-service, guix-service): Change 'start' and 'stop' to gexps; remove 'inputs' field. (guix-build-accounts): Change 'shell' field to a gexp. * gnu/services/networking.scm (static-networking-service): Change 'start' and 'stop' to gexps; remove 'inputs' field. * gnu/services/xorg.scm (slim-service): Likewise. * gnu/services/dmd.scm (dmd-configuration-file): Expect ETC to be a derivation. Change 'config' to a gexp. Use 'gexp->file' instead of 'text-file'. * doc/guix.texi (Defining Services): Update nscd example with gexps, and without 'inputs'. Add xref to "G-Expressions". --- doc/guix.texi | 31 +++++++++--------- gnu/services.scm | 7 ++--- gnu/services/base.scm | 60 +++++++++++++++++------------------ gnu/services/dmd.scm | 77 +++++++++++++++++++++++---------------------- gnu/services/networking.scm | 58 +++++++++++++++++----------------- gnu/services/xorg.scm | 19 +++++------ gnu/system.scm | 44 +++++--------------------- gnu/system/linux.scm | 74 +++++++++++++++++++++---------------------- gnu/system/shadow.scm | 48 ++++++++++++---------------- 9 files changed, 187 insertions(+), 231 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 9fb226c651..bbfdce51fa 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3224,29 +3224,26 @@ like: @lisp (define (nscd-service) - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (with-monad %store-monad (return (service (documentation "Run libc's name service cache daemon.") (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) - - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) + (start #~(make-forkexec-constructor + (string-append #$glibc "/sbin/nscd") + "-f" "/dev/null" "--foreground")) + (stop #~(make-kill-destructor)) + (respawn? #f))))) @end lisp @noindent -The @code{inputs} field specifies that this service depends on the -@var{glibc} package---the package that contains the @command{nscd} -program. The @code{start} and @code{stop} fields are expressions that -make use of dmd's facilities to start and stop processes (@pxref{Service -De- and Constructors,,, dmd, GNU dmd Manual}). The @code{provision} -field specifies the name under which this service is known to dmd, and -@code{documentation} specifies on-line documentation. Thus, the -commands @command{deco start ncsd}, @command{deco stop nscd}, and -@command{deco doc nscd} will do what you would expect (@pxref{Invoking -deco,,, dmd, GNU dmd Manual}). +The @code{start} and @code{stop} fields are G-expressions +(@pxref{G-Expressions}). They refer to dmd's facilities to start and +stop processes (@pxref{Service De- and Constructors,,, dmd, GNU dmd +Manual}). The @code{provision} field specifies the name under which +this service is known to dmd, and @code{documentation} specifies on-line +documentation. Thus, the commands @command{deco start ncsd}, +@command{deco stop nscd}, and @command{deco doc nscd} will do what you +would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}). @c ********************************************************************* diff --git a/gnu/services.scm b/gnu/services.scm index eccde4e9a3..8b89b11b8f 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -26,7 +26,6 @@ service-respawn? service-start service-stop - service-inputs service-user-accounts service-user-groups service-pam-services)) @@ -47,11 +46,9 @@ (default '())) (respawn? service-respawn? ; Boolean (default #t)) - (start service-start) ; expression - (stop service-stop ; expression + (start service-start) ; g-expression + (stop service-stop ; g-expression (default #f)) - (inputs service-inputs ; list of inputs - (default '())) (user-accounts service-user-accounts ; list of (default '())) (user-groups service-user-groups ; list of diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 3145a657f8..9561995243 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -24,6 +24,7 @@ #:use-module ((gnu packages base) #:select (glibc-final)) #:use-module (gnu packages package-management) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -48,8 +49,8 @@ (return (service (documentation "Initialize the machine's host name.") (provision '(host-name)) - (start `(lambda _ - (sethostname ,name))) + (start #~(lambda _ + (sethostname #$name))) (respawn? #f))))) (define* (mingetty-service tty @@ -57,8 +58,7 @@ (motd (text-file "motd" "Welcome.\n")) (allow-empty-passwords? #t)) "Return a service to run mingetty on TTY." - (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) - (motd motd)) + (mlet %store-monad ((motd motd)) (return (service (documentation (string-append "Run mingetty on " tty ".")) @@ -68,10 +68,10 @@ ;; service to be done. (requirement '(host-name)) - (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) - (stop `(make-kill-destructor)) - (inputs `(("mingetty" ,mingetty) - ("motd" ,motd))) + (start #~(make-forkexec-constructor + (string-append #$mingetty "/sbin/mingetty") + "--noclear" #$tty)) + (stop #~(make-kill-destructor)) (pam-services ;; Let 'login' be known to PAM. All the mingetty services will have @@ -83,16 +83,17 @@ (define* (nscd-service #:key (glibc glibc-final)) "Return a service that runs libc's name service cache daemon (nscd)." - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (with-monad %store-monad (return (service (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) + (start + #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") + "-f" "/dev/null" + "--foreground")) + (stop #~(make-kill-destructor)) - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) + (respawn? #f))))) (define (syslog-service) "Return a service that runs 'syslogd' with reasonable default settings." @@ -120,17 +121,17 @@ ") (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents)) - (syslogd (package-file inetutils "libexec/syslogd"))) + ((syslog.conf (text-file "syslog.conf" contents))) (return (service (documentation "Run the syslog daemon (syslogd).") (provision '(syslogd)) - (start `(make-forkexec-constructor ,syslogd "--no-detach" - "--rcfile" ,syslog.conf)) - (stop `(make-kill-destructor)) - (inputs `(("inetutils" ,inetutils) - ("syslog.conf" ,syslog.conf))))))) + (start + #~(make-forkexec-constructor (string-append #$inetutils + "/libexec/syslogd") + "--no-detach" + "--rcfile" #$syslog.conf)) + (stop #~(make-kill-destructor)))))) (define* (guix-build-accounts count #:key (first-uid 30001) @@ -148,8 +149,7 @@ starting at FIRST-UID, and under GID." (gid gid) (comment (format #f "Guix Build User ~2d" n)) (home-directory "/var/empty") - (shell (package-file shadow "sbin/nologin")) - (inputs `(("shadow" ,shadow))))) + (shell #~(string-append #$shadow "/sbin/nologin")))) 1+ 1)))) @@ -157,16 +157,16 @@ starting at FIRST-UID, and under GID." (build-user-gid 30000) (build-accounts 10)) "Return a service that runs the build daemon from GUIX, and has BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." - (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")) - (accounts (guix-build-accounts build-accounts + (mlet %store-monad ((accounts (guix-build-accounts build-accounts #:gid build-user-gid))) (return (service (provision '(guix-daemon)) - (start `(make-forkexec-constructor ,daemon - "--build-users-group" - ,builder-group)) - (stop `(make-kill-destructor)) - (inputs `(("guix" ,guix))) + (start + #~(make-forkexec-constructor (string-append #$guix + "/bin/guix-daemon") + "--build-users-group" + #$builder-group)) + (stop #~(make-kill-destructor)) (user-accounts accounts) (user-groups (list (user-group (name builder-group) diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 54fb5cbfd6..c187c09857 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu services dmd) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (gnu services) #:use-module (ice-9 match) @@ -31,50 +32,50 @@ (define (dmd-configuration-file services etc) "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC (the name of a directory in the store) on startup." +ETC (the derivation that builds the /etc directory) on startup." (define config - `(begin - (use-modules (ice-9 ftw)) + #~(begin + (use-modules (ice-9 ftw)) - (register-services - ,@(map (lambda (service) - `(make - #:docstring ',(service-documentation service) - #:provides ',(service-provision service) - #:requires ',(service-requirement service) - #:respawn? ',(service-respawn? service) - #:start ,(service-start service) - #:stop ,(service-stop service))) - services)) + (register-services + #$@(map (lambda (service) + #~(make + #:docstring '#$(service-documentation service) + #:provides '#$(service-provision service) + #:requires '#$(service-requirement service) + #:respawn? '#$(service-respawn? service) + #:start #$(service-start service) + #:stop #$(service-stop service))) + services)) - ;; /etc is a mixture of static and dynamic settings. Here is where we - ;; initialize it from the static part. - (format #t "populating /etc from ~a...~%" ,etc) - (let ((rm-f (lambda (f) - (false-if-exception (delete-file f))))) - (rm-f "/etc/static") - (symlink ,etc "/etc/static") - (for-each (lambda (file) - ;; TODO: Handle 'shadow' specially so that changed - ;; password aren't lost. - (let ((target (string-append "/etc/" file)) - (source (string-append "/etc/static/" file))) - (rm-f target) - (symlink source target))) - (scandir ,etc - (lambda (file) - (not (member file '("." "..")))))) + ;; /etc is a mixture of static and dynamic settings. Here is where we + ;; initialize it from the static part. + (format #t "populating /etc from ~a...~%" #$etc) + (let ((rm-f (lambda (f) + (false-if-exception (delete-file f))))) + (rm-f "/etc/static") + (symlink #$etc "/etc/static") + (for-each (lambda (file) + ;; TODO: Handle 'shadow' specially so that changed + ;; password aren't lost. + (let ((target (string-append "/etc/" file)) + (source (string-append "/etc/static/" file))) + (rm-f target) + (symlink source target))) + (scandir #$etc + (lambda (file) + (not (member file '("." "..")))))) - ;; Prevent ETC from being GC'd. - (rm-f "/var/guix/gcroots/etc-directory") - (symlink ,etc "/var/guix/gcroots/etc-directory")) + ;; Prevent ETC from being GC'd. + (rm-f "/var/guix/gcroots/etc-directory") + (symlink #$etc "/var/guix/gcroots/etc-directory")) - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") + ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. + (setenv "PATH" "/run/current-system/bin") - (format #t "starting services...~%") - (for-each start ',(append-map service-provision services)))) + (format #t "starting services...~%") + (for-each start '#$(append-map service-provision services)))) - (text-file "dmd.conf" (object->string config))) + (gexp->file "dmd.conf" config)) ;;; dmd.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 317800db50..5522541735 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -20,6 +20,7 @@ #:use-module (gnu services) #:use-module (gnu packages admin) #:use-module (gnu packages linux) + #:use-module (guix gexp) #:use-module (guix monads) #:export (static-networking-service)) @@ -41,40 +42,41 @@ true, it must be a string specifying the default network gateway." ;; TODO: Eventually we should do this using Guile's networking procedures, ;; like 'configure-qemu-networking' does, but the patch that does this is ;; not yet in stock Guile. - (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) - (route (package-file net-tools "sbin/route"))) + (with-monad %store-monad (return (service (documentation (string-append "Set up networking on the '" interface "' interface using a static IP address.")) (provision '(networking)) - (start `(lambda _ - ;; Return #t if successfully started. - (and (zero? (system* ,ifconfig ,interface ,ip "up")) - ,(if gateway - `(zero? (system* ,route "add" "-net" "default" - "gw" ,gateway)) - #t) - ,(if (pair? name-servers) - `(call-with-output-file "/etc/resolv.conf" - (lambda (port) - (display - "# Generated by 'static-networking-service'.\n" - port) - (for-each (lambda (server) - (format port "nameserver ~a~%" - server)) - ',name-servers))) - #t)))) - (stop `(lambda _ + (start #~(lambda _ + ;; Return #t if successfully started. + (and (zero? (system* (string-append #$inetutils + "/bin/ifconfig") + #$interface #$ip "up")) + #$(if gateway + #~(zero? (system* (string-append #$net-tools + "/sbin/route") + "add" "-net" "default" + "gw" #$gateway)) + #t) + #$(if (pair? name-servers) + #~(call-with-output-file "/etc/resolv.conf" + (lambda (port) + (display + "# Generated by 'static-networking-service'.\n" + port) + (for-each (lambda (server) + (format port "nameserver ~a~%" + server)) + '#$name-servers))) + #t)))) + (stop #~(lambda _ ;; Return #f is successfully stopped. - (not (and (system* ,ifconfig ,interface "down") - (system* ,route "del" "-net" "default"))))) - (respawn? #f) - (inputs `(("inetutils" ,inetutils) - ,@(if gateway - `(("net-tools" ,net-tools)) - '()))))))) + (not (and (system* (string-append #$inetutils "/sbin/ifconfig") + #$interface "down") + (system* (string-append #$net-tools "/sbin/route") + "del" "-net" "default"))))) + (respawn? #f))))) ;;; networking.scm ends here diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 086150a658..81b5bc17a5 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages gnustep) #:use-module (gnu packages admin) #:use-module (gnu packages bash) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix derivations) #:export (xorg-start-command @@ -190,9 +191,7 @@ reboot_cmd " dmd "/sbin/reboot (string-append "auto_login yes\ndefault_user " default-user) "")))) - (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) - (bash-bin (package-file bash "bin/bash")) - (slim.cfg (slim.cfg))) + (mlet %store-monad ((slim.cfg (slim.cfg))) (return (service (documentation "Xorg display server") @@ -200,15 +199,11 @@ reboot_cmd " dmd "/sbin/reboot (requirement '(host-name)) (start ;; XXX: Work around the inability to specify env. vars. directly. - `(make-forkexec-constructor - ,bash-bin "-c" - ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) - " " slim-bin - " -nodaemon"))) - (stop `(make-kill-destructor)) - (inputs `(("slim" ,slim) - ("slim.cfg" ,slim.cfg) - ("bash" ,bash))) + #~(make-forkexec-constructor + (string-append #$bash "/bin/sh") "-c" + (string-append "SLIM_CFGFILE=" #$slim.cfg + " " #$slim "/bin/slim" " -nodaemon"))) + (stop #~(make-kill-destructor)) (respawn? #t) (pam-services ;; Tell PAM about 'slim'. diff --git a/gnu/system.scm b/gnu/system.scm index 65b524d387..20c49c182a 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -192,29 +192,6 @@ as an inputs; additional inputs, such as derivations, are taken from INPUTS." #:inputs inputs #:local-build? #t)))) -(define (links inputs) - "Return a directory with symbolic links to all of INPUTS. This is -essentially useful when one wants to keep references to all of INPUTS, be they -directories or regular files." - (define builder - '(begin - (use-modules (srfi srfi-1)) - - (let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (chdir out) - (fold (lambda (file number) - (symlink file (number->string number)) - (+ 1 number)) - 0 - (map cdr %build-inputs)) - #t))) - - (mlet %store-monad ((inputs (lower-inputs inputs))) - (derivation-expression "links" builder - #:inputs inputs - #:local-build? #t))) - (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") (accounts '()) @@ -272,12 +249,14 @@ alias ll='ls -l' ("shells" ,shells) ("profile" ,(derivation->output-path bashrc)) ("localtime" ,tz-file) - ("passwd" ,passwd) - ("shadow" ,shadow) + ("passwd" ,(derivation->output-path passwd)) + ("shadow" ,(derivation->output-path shadow)) ("group" ,group)))) (file-union files #:inputs `(("net" ,net-base) ("pam.d" ,pam.d) + ("passwd" ,passwd) + ("shadow" ,shadow) ("bashrc" ,bashrc) ("tzdata" ,tzdata)) #:name "etc"))) @@ -327,8 +306,7 @@ we're running in the final root." (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (dmd-conf (dmd-configuration-file services - (derivation->output-path etc)))) + (dmd-conf (dmd-configuration-file services etc))) (gexp->file "boot" #~(execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf)))) @@ -357,25 +335,19 @@ we're running in the final root." (linux-arguments `("--root=/dev/sda1" ,(string-append "--load=" boot))) (initrd initrd-file)))) - (grub.cfg (grub-configuration-file entries)) - (accounts (operating-system-accounts os)) - (extras (links (delete-duplicates - (append (append-map service-inputs services) - (append-map user-account-inputs accounts)))))) + (grub.cfg (grub-configuration-file entries))) (file-union `(("boot" ,boot) ("kernel" ,kernel-dir) ("initrd" ,initrd-file) ("profile" ,profile) ("grub.cfg" ,grub.cfg) - ("etc" ,etc) - ("system-inputs" ,(derivation->output-path extras))) + ("etc" ,etc)) #:inputs `(("boot" ,boot-drv) ("kernel" ,kernel) ("initrd" ,initrd) ("bash" ,bash) ("profile" ,profile-drv) - ("etc" ,etc-drv) - ("system-inputs" ,extras)) + ("etc" ,etc-drv)) #:name "system"))) ;;; system.scm ends here diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 65868ce9bf..efe27c55c3 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix records) #:use-module (guix derivations) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -58,58 +59,56 @@ (define-record-type* 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 + (control pam-entry-control) ; string + (module pam-entry-module) ; file name + (arguments pam-entry-arguments ; list of string-valued g-expressions (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) + "Return the derivation building the configuration file for SERVICE, to be +dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." + (define (entry->gexp type entry) (match entry (($ control module (arguments ...)) - (string-append type " " - control " " module " " - (string-join arguments) - "\n")))) + #~(format #t "~a ~a ~a ~a~%" + #$type #$control #$module + (string-join (list #$@arguments)))))) (match 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 builder + #~(begin + (with-output-to-file #$output + (lambda () + #$@(append (map (cut entry->gexp "account" <>) account) + (map (cut entry->gexp "auth" <>) auth) + (map (cut entry->gexp "password" <>) password) + (map (cut entry->gexp "session" <>) session)) + #t)))) + + (gexp->derivation name builder)))) (define (pam-services->directory services) "Return the derivation to build the configuration directory to be used as /etc/pam.d for SERVICES." (mlet %store-monad ((names -> (map pam-service-name services)) - (files (mapm %store-monad - (match-lambda - ((and service ($ name)) - (let ((config (pam-service->configuration service))) - (text-file (string-append name ".pam") config)))) - - ;; XXX: Eventually, SERVICES may be a list of monadic - ;; values instead of plain values. - (map return services)))) + (files (sequence %store-monad + (map pam-service->configuration + ;; XXX: Eventually, SERVICES may be a list of + ;; monadic values instead of plain values. + services)))) (define builder - '(begin - (use-modules (ice-9 match)) + #~(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))) + (mkdir #$output) + (for-each (match-lambda + ((name file) + (symlink file (string-append #$output "/" name)))) + '#$(zip names files)))) - (derivation-expression "pam.d" builder - #:inputs (zip names files)))) + (gexp->derivation "pam.d" builder))) (define %pam-other-services ;; The "other" PAM configuration, which denies everything (see @@ -149,7 +148,8 @@ should be the name of a file used as the message-of-the-day." (pam-entry (control "optional") (module "pam_motd.so") - (arguments (list (string-append "motd=" motd))))) + (arguments + (list #~(string-append "motd=" #$motd))))) (list unix)))))))) ;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 2a85a20ebb..52242ee4e0 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix records) #:use-module (guix packages) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module ((gnu packages admin) #:select (shadow)) @@ -35,7 +36,6 @@ user-account-comment user-account-home-directory user-account-shell - user-account-inputs user-group user-group? @@ -63,9 +63,8 @@ (gid user-account-gid) (comment user-account-comment (default "")) (home-directory user-account-home-directory) - (shell user-account-shell ; monadic value - (default (package-file bash "bin/bash"))) - (inputs user-account-inputs (default `(("bash" ,bash))))) + (shell user-account-shell ; gexp + (default #~(string-append #$bash "/bin/bash")))) (define-record-type* user-group make-user-group @@ -97,29 +96,22 @@ 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) - (with-monad %store-monad - (let loop ((accounts accounts) - (result '())) - (match accounts - ((($ name pass uid gid comment home-dir mshell) - rest ...) - (mlet %store-monad ((shell mshell)) - (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)))) - (() - (return (string-join (reverse result) "\n" 'suffix))))))) + (define account-exp + (match-lambda + (($ name pass uid gid comment home-dir shell) + (if shadow? ; XXX: use (crypt PASS …)? + #~(format #t "~a::::::::~%" #$name) + #~(format #t "~a:x:~a:~a:~a:~a:~a~%" + #$name #$(number->string uid) #$(number->string gid) + #$comment #$home-dir #$shell))))) - (mlet %store-monad ((contents (contents))) - (text-file (if shadow? "shadow" "passwd") contents))) + (define builder + #~(begin + (with-output-to-file #$output + (lambda () + #$@(map account-exp accounts) + #t)))) + + (gexp->derivation (if shadow? "shadow" "passwd") builder)) ;;; shadow.scm ends here -- cgit v1.2.3 From 23f6056b5022ae5051491a3ccecd2fea01105087 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 16:50:34 +0200 Subject: system: Change 'file-union' to use gexps. * gnu/system.scm (file-union): Make 'name' the first parameter; remove 'inputs' parameter. Rewrite using 'gexp->derivation'. (etc-directory): Adjust accordingly. (operating-system-derivation): Ditto. --- gnu/system.scm | 118 ++++++++++++++++++--------------------------------------- 1 file changed, 37 insertions(+), 81 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index 20c49c182a..b52daf7917 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -153,44 +153,21 @@ input tuples." #:guile-for-build guile #:local-build? #t))) -(define* (file-union files - #:key (inputs '()) (name "file-union")) +(define* (file-union name files) "Return a derivation that builds a directory containing all of FILES. Each item in FILES must be a list where the first element is the file name to use -in the new directory, and the second element is the target file. - -The subset of FILES corresponding to plain store files is automatically added -as an inputs; additional inputs, such as derivations, are taken from INPUTS." - (mlet %store-monad ((inputs (lower-inputs inputs))) - (let* ((outputs (append-map (match-lambda - ((_ (? derivation? drv)) - (list (derivation->output-path drv))) - ((_ (? derivation? drv) sub-drv ...) - (map (cut derivation->output-path drv <>) - sub-drv)) - (_ '())) - inputs)) - (inputs (append inputs - (filter (match-lambda - ((_ file) - ;; Elements of FILES that are store - ;; files and that do not correspond to - ;; the output of INPUTS are considered - ;; inputs (still here?). - (and (direct-store-path? file) - (not (member file outputs))))) - files)))) - (derivation-expression name - `(let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (chdir out) - ,@(map (match-lambda - ((name target) - `(symlink ,target ,name))) - files)) +in the new directory, and the second element is a gexp denoting the target +file." + (define builder + #~(begin + (mkdir #$output) + (chdir #$output) + #$@(map (match-lambda + ((target source) + #~(symlink #$source #$target))) + files))) - #:inputs inputs - #:local-build? #t)))) + (gexp->derivation name builder)) (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") @@ -200,10 +177,7 @@ as an inputs; additional inputs, such as derivations, are taken from INPUTS." (profile "/var/run/current-system/profile")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad - ((services (package-file net-base "etc/services")) - (protocols (package-file net-base "etc/protocols")) - (rpc (package-file net-base "etc/rpc")) - (passwd (passwd-file accounts)) + ((passwd (passwd-file accounts)) (shadow (passwd-file accounts #:shadow? #t)) (group (group-file groups)) (pam.d (pam-services->directory pam-services)) @@ -236,30 +210,21 @@ export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' alias ll='ls -l' -")) - - (tz-file (package-file tzdata - (string-append "share/zoneinfo/" timezone))) - (files -> `(("services" ,services) - ("protocols" ,protocols) - ("rpc" ,rpc) - ("pam.d" ,(derivation->output-path pam.d)) - ("login.defs" ,login.defs) - ("issue" ,issue) - ("shells" ,shells) - ("profile" ,(derivation->output-path bashrc)) - ("localtime" ,tz-file) - ("passwd" ,(derivation->output-path passwd)) - ("shadow" ,(derivation->output-path shadow)) - ("group" ,group)))) - (file-union files - #:inputs `(("net" ,net-base) - ("pam.d" ,pam.d) - ("passwd" ,passwd) - ("shadow" ,shadow) - ("bashrc" ,bashrc) - ("tzdata" ,tzdata)) - #:name "etc"))) +"))) + (file-union "etc" + `(("services" ,#~(string-append #$net-base "/etc/services")) + ("protocols" ,#~(string-append #$net-base "/etc/protocols")) + ("rpc" ,#~(string-append #$net-base "/etc/rpc")) + ("pam.d" ,#~#$pam.d) + ("login.defs" ,#~#$login.defs) + ("issue" ,#~#$issue) + ("shells" ,#~#$shells) + ("profile" ,#~#$bashrc) + ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" + #$timezone)) + ("passwd" ,#~#$passwd) + ("shadow" ,#~#$shadow) + ("group" ,#~#$group))))) (define (operating-system-profile os) "Return a derivation that builds the default profile of OS." @@ -314,15 +279,12 @@ we're running in the final root." (define (operating-system-derivation os) "Return a derivation that builds OS." (mlet* %store-monad - ((profile-drv (operating-system-profile os)) - (profile -> (derivation->output-path profile-drv)) - (etc-drv (operating-system-etc-directory os)) - (etc -> (derivation->output-path etc-drv)) + ((profile (operating-system-profile os)) + (etc (operating-system-etc-directory os)) (services (sequence %store-monad (operating-system-services os))) (boot-drv (operating-system-boot-script os)) (boot -> (derivation->output-path boot-drv)) (kernel -> (operating-system-kernel os)) - (kernel-dir (package-file kernel)) (initrd (operating-system-initrd os)) (initrd-file -> (string-append (derivation->output-path initrd) "/initrd")) @@ -336,18 +298,12 @@ we're running in the final root." ,(string-append "--load=" boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries))) - (file-union `(("boot" ,boot) - ("kernel" ,kernel-dir) - ("initrd" ,initrd-file) - ("profile" ,profile) - ("grub.cfg" ,grub.cfg) - ("etc" ,etc)) - #:inputs `(("boot" ,boot-drv) - ("kernel" ,kernel) - ("initrd" ,initrd) - ("bash" ,bash) - ("profile" ,profile-drv) - ("etc" ,etc-drv)) - #:name "system"))) + (file-union "system" + `(("boot" ,#~#$boot-drv) + ("kernel" ,#~#$kernel) + ("initrd" ,#~(string-append #$initrd "/initrd")) + ("profile" ,#~#$profile) + ("grub.cfg" ,#~#$grub.cfg) + ("etc" ,#~#$etc))))) ;;; system.scm ends here -- cgit v1.2.3 From f6a7b21df7b499e8d304cc96fc949ec889e1eb10 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Apr 2014 23:40:24 +0200 Subject: system: grub: Rewrite using gexps. * gnu/system/grub.scm (grub-configuration-file): Rewrite using 'gexp->derivation'. * gnu/system.scm (operating-system-derivation): Adjust accordingly. --- gnu/system.scm | 15 +++++++-------- gnu/system/grub.scm | 53 ++++++++++++++++++++++++----------------------------- 2 files changed, 31 insertions(+), 37 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index b52daf7917..0b2501392d 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -282,26 +282,25 @@ we're running in the final root." ((profile (operating-system-profile os)) (etc (operating-system-etc-directory os)) (services (sequence %store-monad (operating-system-services os))) - (boot-drv (operating-system-boot-script os)) - (boot -> (derivation->output-path boot-drv)) + (boot (operating-system-boot-script os)) (kernel -> (operating-system-kernel os)) (initrd (operating-system-initrd os)) - (initrd-file -> (string-append (derivation->output-path initrd) - "/initrd")) + (initrd-file -> #~(string-append #$initrd "/initrd")) (entries -> (list (menu-entry (label (string-append "GNU system with " (package-full-name kernel) " (technology preview)")) (linux kernel) - (linux-arguments `("--root=/dev/sda1" - ,(string-append "--load=" boot))) + (linux-arguments + (list "--root=/dev/sda1" + #~(string-append "--load=" #$boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries))) (file-union "system" - `(("boot" ,#~#$boot-drv) + `(("boot" ,#~#$boot) ("kernel" ,#~#$kernel) - ("initrd" ,#~(string-append #$initrd "/initrd")) + ("initrd" ,initrd-file) ("profile" ,#~#$profile) ("grub.cfg" ,#~#$grub.cfg) ("etc" ,#~#$etc))))) diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 5dc0b85ff2..1893672a2a 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -22,6 +22,7 @@ #:use-module (guix derivations) #:use-module (guix records) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (menu-entry @@ -40,45 +41,39 @@ (label menu-entry-label) (linux menu-entry-linux) (linux-arguments menu-entry-linux-arguments - (default '())) - (initrd menu-entry-initrd)) ; file name of the initrd + (default '())) ; list of string-valued gexps + (initrd menu-entry-initrd)) ; file name of the initrd as a gexp (define* (grub-configuration-file entries #:key (default-entry 1) (timeout 5) (system (%current-system))) "Return the GRUB configuration file for ENTRIES, a list of objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT." - (define (prologue kernel) - (format #f " -set default=~a -set timeout=~a -search.file ~a~%" - default-entry timeout kernel)) - - (define (bzImage) - (any (match-lambda - (($ _ linux) - (package-file linux "bzImage" - #:system system))) - entries)) - - (define entry->text + (define entry->gexp (match-lambda (($ label linux arguments initrd) - (mlet %store-monad ((linux (package-file linux "bzImage" - #:system system))) - (return (format #f "menuentry ~s { - linux ~a ~a + #~(format port "menuentry ~s { + linux ~a/bzImage ~a initrd ~a }~%" - label - linux (string-join arguments) initrd)))))) + #$label + #$linux (string-join (list #$@arguments)) + #$initrd)))) + + (define builder + #~(call-with-output-file #$output + (lambda (port) + (format port " +set default=~a +set timeout=~a +search.file ~a/bzImage~%" + #$default-entry #$timeout + #$(any (match-lambda + (($ _ linux) + linux)) + entries)) + #$@(map entry->gexp entries)))) - (mlet %store-monad ((kernel (bzImage)) - (body (sequence %store-monad - (map entry->text entries)))) - (text-file "grub.cfg" - (string-append (prologue kernel) - (string-concatenate body))))) + (gexp->derivation "grub.cfg" builder)) ;;; grub.scm ends here -- cgit v1.2.3 From 8779d3429414b62d3071987bacca7a9e0c8abc06 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 19:28:47 +0200 Subject: services: xorg: Rewrite using gexps. * gnu/services/xorg.scm (xorg-start-command): Rewrite in terms of 'gexp->script'. (xinitrc): Likewise. --- gnu/services/xorg.scm | 93 ++++++++++++++++----------------------------------- 1 file changed, 29 insertions(+), 64 deletions(-) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 81b5bc17a5..e47b33c9b8 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -87,77 +87,42 @@ Section \"Screen\" Device \"Device-vesa\" EndSection")) - (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) - (xorg-bin (package-file xorg-server "bin/X")) - (dri (package-file mesa "lib/dri")) - (xkbcomp-bin (package-file xkbcomp "bin")) - (xkb-dir (package-file xkeyboard-config - "share/X11/xkb")) - (config (xserver.conf))) - (define builder + (mlet %store-monad ((config (xserver.conf))) + (define script ;; Write a small wrapper around the X server. - `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) - (write '(begin - (setenv "XORG_DRI_DRIVER_PATH" ,dri) - (setenv "XKB_BINDIR" ,xkbcomp-bin) - - (apply execl - - ,xorg-bin "-ac" "-logverbose" "-verbose" - "-xkbdir" ,xkb-dir - "-config" ,(derivation->output-path config) - "-nolisten" "tcp" "-terminate" - - ;; Note: SLiM and other display managers add the - ;; '-auth' flag by themselves. - (cdr (command-line)))) - port))) - (chmod out #o555) - #t)) - - (mlet %store-monad ((inputs (lower-inputs - `(("xorg" ,xorg-server) - ("xkbcomp" ,xkbcomp) - ("xkeyboard-config" ,xkeyboard-config) - ("mesa" ,mesa) - ("guile" ,guile) - ("xorg.conf" ,config))))) - (derivation-expression "start-xorg" builder - #:inputs inputs)))) + #~(begin + (setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri")) + (setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin")) + + (apply execl (string-append #$xorg-server "/bin/X") + "-ac" "-logverbose" "-verbose" + "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") + "-config" #$config + "-nolisten" "tcp" "-terminate" + + ;; Note: SLiM and other display managers add the + ;; '-auth' flag by themselves. + (cdr (command-line))))) + + (gexp->script "start-xorg" script))) (define* (xinitrc #:key (guile guile-final) (ratpoison ratpoison) (windowmaker windowmaker)) "Return a system-wide xinitrc script that starts the specified X session." - (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) - (ratpoison-bin (package-file ratpoison "bin/ratpoison")) - (wmaker-bin (package-file windowmaker "bin/wmaker")) - (inputs (lower-inputs - `(("raptoison" ,ratpoison) - ("wmaker" ,windowmaker))))) - (define builder - `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) - (write '(begin - (use-modules (ice-9 match)) - - ;; TODO: Check for ~/.xsession. - (match (command-line) - ((_ "ratpoison") - (execl ,ratpoison-bin)) - (_ - (execl ,wmaker-bin)))) - port))) - (chmod out #o555) - #t)) - - (derivation-expression "xinitrc" builder #:inputs inputs))) + (define builder + #~(begin + (use-modules (ice-9 match)) + + ;; TODO: Check for ~/.xsession. + (match (command-line) + ((_ "ratpoison") + (execl (string-append #$ratpoison "/bin/ratpoison"))) + (_ + (execl (string-append #$windowmaker "/bin/wmaker")))))) + + (gexp->script "xinitrc" builder)) (define* (slim-service #:key (slim slim) (allow-empty-passwords? #t) auto-login? -- cgit v1.2.3 From 8c35bfb68c63077cbc40214b87c2ac678a1443ba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 22:40:48 +0200 Subject: system: Rewrite 'union' using gexps. * gnu/system.scm (union): Rewrite using 'gexp->derivation'. --- gnu/system.scm | 43 ++++++++++++++----------------------------- 1 file changed, 14 insertions(+), 29 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index 0b2501392d..86904d9be2 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -120,38 +120,23 @@ "Return a derivation that builds the union of INPUTS. INPUTS is a list of input tuples." (define builder - '(begin - (use-modules (guix build union)) + #~(begin + (use-modules (guix build union)) + + (define inputs '#$inputs) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) - (let ((output (assoc-ref %outputs "out")) - (inputs (map cdr %build-inputs))) - (format #t "building union `~a' with ~a packages...~%" - output (length inputs)) - (union-build output inputs)))) + (format #t "building union `~a' with ~a packages...~%" + #$output (length inputs)) + (union-build #$output inputs))) - (mlet %store-monad - ((inputs (sequence %store-monad - (map (match-lambda - ((or ((? package? p)) (? package? p)) - (mlet %store-monad - ((drv (package->derivation p system))) - (return `(,name ,drv)))) - (((? package? p) output) - (mlet %store-monad - ((drv (package->derivation p system))) - (return `(,name ,drv ,output)))) - (x - (return x))) - inputs)))) - (derivation-expression name builder - #:system system - #:inputs inputs - #:modules '((guix build union)) - #:guile-for-build guile - #:local-build? #t))) + (gexp->derivation name builder + #:system system + #:modules '((guix build union)) + #:guile-for-build guile + #:local-build? #t)) (define* (file-union name files) "Return a derivation that builds a directory containing all of FILES. Each -- cgit v1.2.3 From 0c21d92b1cb0f7fa2b2d43cae1d84d32ccfc1393 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 23:06:15 +0200 Subject: linux-initrd: Rewrite using gexps. * gnu/system/linux-initrd.scm (expression->initrd): Rename 'inputs' parameter to 'to-copy'. Remove 'files-to-copy'. Rewrite 'builder' as a gexp, and use 'gexp->derivation'. (qemu-initrd): Adjust accordingly. --- gnu/system/linux-initrd.scm | 298 ++++++++++++++++++++------------------------ 1 file changed, 137 insertions(+), 161 deletions(-) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 786e068764..6e04ad150f 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -18,6 +18,7 @@ (define-module (gnu system linux-initrd) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix)) @@ -52,14 +53,14 @@ (name "guile-initrd") (system (%current-system)) (modules '()) - (inputs '()) + (to-copy '()) (linux #f) (linux-modules '())) "Return a package that contains a Linux initrd (a gzipped cpio archive) containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list -of `.ko' file names to be copied from LINUX into the initrd. INPUTS is a list -of additional inputs to be copied in the initrd. MODULES is a list of Guile -module names to be embedded in the initrd." +of `.ko' file names to be copied from LINUX into the initrd. TO-COPY is a +list of additional derivations or packages to copy to the initrd. MODULES is +a list of Guile module names to be embedded in the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. @@ -68,154 +69,129 @@ module names to be embedded in the initrd." ;; Return a regexp that matches STR exactly. (string-append "^" (regexp-quote str) "$")) - (define (files-to-copy) - (mlet %store-monad ((inputs (lower-inputs inputs))) - (return (map (match-lambda - ((_ drv) - (derivation->output-path drv)) - ((_ drv sub-drv) - (derivation->output-path drv sub-drv))) - inputs)))) + (mlet* %store-monad ((source (imported-modules modules)) + (compiled (compiled-modules modules))) + (define builder + ;; TODO: Move most of this code to (guix build linux-initrd). + #~(begin + (use-modules (guix build utils) + (ice-9 pretty-print) + (ice-9 popen) + (ice-9 match) + (ice-9 ftw) + (srfi srfi-26) + (system base compile) + (rnrs bytevectors) + ((system foreign) #:select (sizeof))) - (define (builder to-copy) - `(begin - (use-modules (guix build utils) - (ice-9 pretty-print) - (ice-9 popen) - (ice-9 match) - (ice-9 ftw) - (srfi srfi-26) - (system base compile) - (rnrs bytevectors) - ((system foreign) #:select (sizeof))) + (let ((cpio (string-append #$cpio "/bin/cpio")) + (gzip (string-append #$gzip "/bin/gzip")) + (modules #$source) + (gos #$compiled) + (scm-dir (string-append "share/guile/" (effective-version))) + (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" + (effective-version) + (if (eq? (native-endianness) (endianness little)) + "LE" + "BE") + (sizeof '*) + (effective-version)))) + (mkdir #$output) + (mkdir "contents") + (with-directory-excursion "contents" + (copy-recursively #$guile ".") + (call-with-output-file "init" + (lambda (p) + (format p "#!/bin/guile -ds~%!#~%" #$guile) + (pretty-print '#$exp p))) + (chmod "init" #o555) + (chmod "bin/guile" #o555) - (let ((guile (assoc-ref %build-inputs "guile")) - (cpio (string-append (assoc-ref %build-inputs "cpio") - "/bin/cpio")) - (gzip (string-append (assoc-ref %build-inputs "gzip") - "/bin/gzip")) - (modules (assoc-ref %build-inputs "modules")) - (gos (assoc-ref %build-inputs "modules/compiled")) - (scm-dir (string-append "share/guile/" (effective-version))) - (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" - (effective-version) - (if (eq? (native-endianness) (endianness little)) - "LE" - "BE") - (sizeof '*) - (effective-version))) - (out (assoc-ref %outputs "out"))) - (mkdir out) - (mkdir "contents") - (with-directory-excursion "contents" - (copy-recursively guile ".") - (call-with-output-file "init" - (lambda (p) - (format p "#!/bin/guile -ds~%!#~%" guile) - (pretty-print ',exp p))) - (chmod "init" #o555) - (chmod "bin/guile" #o555) + ;; Copy Guile modules. + (chmod scm-dir #o777) + (copy-recursively modules scm-dir + #:follow-symlinks? #t) + (copy-recursively gos (string-append "lib/guile/" + (effective-version) "/ccache") + #:follow-symlinks? #t) - ;; Copy Guile modules. - (chmod scm-dir #o777) - (copy-recursively modules scm-dir - #:follow-symlinks? #t) - (copy-recursively gos (string-append "lib/guile/" - (effective-version) "/ccache") - #:follow-symlinks? #t) + ;; Compile `init'. + (mkdir-p go-dir) + (set! %load-path (cons modules %load-path)) + (set! %load-compiled-path (cons gos %load-compiled-path)) + (compile-file "init" + #:opts %auto-compilation-options + #:output-file (string-append go-dir "/init.go")) - ;; Compile `init'. - (mkdir-p go-dir) - (set! %load-path (cons modules %load-path)) - (set! %load-compiled-path (cons gos %load-compiled-path)) - (compile-file "init" - #:opts %auto-compilation-options - #:output-file (string-append go-dir "/init.go")) + ;; Copy Linux modules. + (let* ((linux #$linux) + (module-dir (and linux + (string-append linux "/lib/modules")))) + (mkdir "modules") + #$@(map (lambda (module) + #~(match (find-files module-dir + #$(string->regexp module)) + ((file) + (format #t "copying '~a'...~%" file) + (copy-file file (string-append "modules/" + #$module))) + (() + (error "module not found" #$module module-dir)) + ((_ ...) + (error "several modules by that name" + #$module module-dir)))) + linux-modules)) - ;; Copy Linux modules. - (let* ((linux (assoc-ref %build-inputs "linux")) - (module-dir (and linux - (string-append linux "/lib/modules")))) - (mkdir "modules") - ,@(map (lambda (module) - `(match (find-files module-dir - ,(string->regexp module)) - ((file) - (format #t "copying '~a'...~%" file) - (copy-file file (string-append "modules/" - ,module))) - (() - (error "module not found" ,module module-dir)) - ((_ ...) - (error "several modules by that name" - ,module module-dir)))) - linux-modules)) + (let ((store #$(string-append "." (%store-prefix))) + (to-copy '#$to-copy)) + (unless (null? to-copy) + (mkdir-p store)) + ;; XXX: Should we do export-references-graph? + (for-each (lambda (input) + (let ((target + (string-append store "/" + (basename input)))) + (copy-recursively input target))) + to-copy)) - ,@(if (null? to-copy) - '() - `((let ((store ,(string-append "." (%store-prefix)))) - (mkdir-p store) - ;; XXX: Should we do export-references-graph? - (for-each (lambda (input) - (let ((target - (string-append store "/" - (basename input)))) - (copy-recursively input target))) - ',to-copy)))) + ;; Reset the timestamps of all the files that will make it in the + ;; initrd. + (for-each (cut utime <> 0 0 0 0) + (find-files "." ".*")) - ;; Reset the timestamps of all the files that will make it in the - ;; initrd. - (for-each (cut utime <> 0 0 0 0) - (find-files "." ".*")) + (system* cpio "--version") + (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" + "-O" (string-append #$output "/initrd") + "-H" "newc" "--null"))) + (define print0 + (let ((len (string-length "./"))) + (lambda (file) + (format pipe "~a\0" (string-drop file len))))) - (system* cpio "--version") - (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" - "-O" (string-append out "/initrd") - "-H" "newc" "--null"))) - (define print0 - (let ((len (string-length "./"))) - (lambda (file) - (format pipe "~a\0" (string-drop file len))))) + ;; Note: as per `ramfs-rootfs-initramfs.txt', always add + ;; directory entries before the files that are inside of it: "The + ;; Linux kernel cpio extractor won't create files in a directory + ;; that doesn't exist, so the directory entries must go before + ;; the files that go in those directories." + (file-system-fold (const #t) + (lambda (file stat result) ; leaf + (print0 file)) + (lambda (dir stat result) ; down + (unless (string=? dir ".") + (print0 dir))) + (const #f) ; up + (const #f) ; skip + (const #f) + #f + ".") - ;; Note: as per `ramfs-rootfs-initramfs.txt', always add - ;; directory entries before the files that are inside of it: "The - ;; Linux kernel cpio extractor won't create files in a directory - ;; that doesn't exist, so the directory entries must go before - ;; the files that go in those directories." - (file-system-fold (const #t) - (lambda (file stat result) ; leaf - (print0 file)) - (lambda (dir stat result) ; down - (unless (string=? dir ".") - (print0 dir))) - (const #f) ; up - (const #f) ; skip - (const #f) - #f - ".") + (and (zero? (close-pipe pipe)) + (with-directory-excursion #$output + (and (zero? (system* gzip "--best" "initrd")) + (rename-file "initrd.gz" "initrd"))))))))) - (and (zero? (close-pipe pipe)) - (with-directory-excursion out - (and (zero? (system* gzip "--best" "initrd")) - (rename-file "initrd.gz" "initrd"))))))))) - - (mlet* %store-monad - ((source (imported-modules modules)) - (compiled (compiled-modules modules)) - (inputs (lower-inputs - `(("guile" ,guile) - ("cpio" ,cpio) - ("gzip" ,gzip) - ("modules" ,source) - ("modules/compiled" ,compiled) - ,@(if linux - `(("linux" ,linux)) - '()) - ,@inputs))) - (to-copy (files-to-copy))) - (derivation-expression name (builder to-copy) - #:modules '((guix build utils)) - #:inputs inputs))) + (gexp->derivation name builder + #:modules '((guix build utils))))) (define* (qemu-initrd #:key guile-modules-in-chroot? @@ -257,26 +233,26 @@ to it are lost." '("fuse.ko") '()))) - (mlet %store-monad - ((unionfs (package-file unionfs-fuse/static "bin/unionfs"))) - (expression->initrd - `(begin - (use-modules (guix build linux-initrd)) + (expression->initrd + #~(begin + (use-modules (guix build linux-initrd) + (srfi srfi-26)) - (boot-system #:mounts ',mounts - #:linux-modules ',linux-modules - #:qemu-guest-networking? #t - #:guile-modules-in-chroot? ',guile-modules-in-chroot? - #:unionfs ,unionfs - #:volatile-root? ',volatile-root?)) - #:name "qemu-initrd" - #:modules '((guix build utils) - (guix build linux-initrd)) - #:linux linux-libre - #:linux-modules linux-modules - #:inputs (if volatile-root? - `(("unionfs" ,unionfs-fuse/static)) - '())))) + (boot-system #:mounts '#$mounts + #:linux-modules '#$linux-modules + #:qemu-guest-networking? #t + #:guile-modules-in-chroot? '#$guile-modules-in-chroot? + #:unionfs (and=> #$(and volatile-root? unionfs-fuse/static) + (cut string-append <> "/bin/unionfs")) + #:volatile-root? '#$volatile-root?)) + #:name "qemu-initrd" + #:modules '((guix build utils) + (guix build linux-initrd)) + #:to-copy (if volatile-root? + (list unionfs-fuse/static) + '()) + #:linux linux-libre + #:linux-modules linux-modules)) (define (gnu-system-initrd) "Initrd for the GNU system itself, with nothing QEMU-specific." -- cgit v1.2.3 From ada3df03e33f686467ce4e887381e8753a3e603b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Apr 2014 23:19:11 +0200 Subject: monads: Hide 'derivation-expression' and 'lower-inputs'. * guix/monads.scm: Unexport 'lower-inputs' and 'derivation-expression'. (text-file*): Add comment about the switch to 'gexp->derivation'. (lower-inputs): Add comment about its doom. (derivation-expression): Likewise. * guix/gexp.scm (lower-inputs*): Rename to... (lower-inputs): ... this. Update callers. * tests/monads.scm (derivation-expression): New procedure. * doc/guix.texi (The Store Monad): Use 'gexp->derivation' instead of 'derivation-expression'. Remove documentation of 'derivation-expression'. * guix/ui.scm (read/eval): Use THE-ROOT-MODULE so that macros are properly expanded. * tests/guix-build.sh: Use 'gexp->derivation' instead of 'derivation-expression'.monads: Hide 'derivation-expression' and 'lower-inputs'. --- doc/guix.texi | 14 +++----------- guix/gexp.scm | 5 ++--- guix/monads.scm | 8 ++++---- guix/ui.scm | 2 +- tests/guix-build.sh | 7 ++++--- tests/monads.scm | 3 +++ 6 files changed, 17 insertions(+), 22 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index bbfdce51fa..3ae2b7e00b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1868,11 +1868,12 @@ Consider this ``normal'' procedure: Using @code{(guix monads)}, it may be rewritten as a monadic function: +@c FIXME: Find a better example, one that uses 'mlet'. @example (define (sh-symlink) ;; Same, but return a monadic value. - (mlet %store-monad ((sh (package-file bash "bin"))) - (derivation-expression "sh" `(symlink ,sh %output)))) + (gexp->derivation "sh" + #~(symlink (string-append #$bash "/bin/bash") #$output))) @end example There are two things to note in the second version: the @code{store} @@ -1973,15 +1974,6 @@ directory of @var{package}. When @var{file} is omitted, return the name of the @var{output} directory of @var{package}. @end deffn -@deffn {Monadic Procedure} derivation-expression @var{name} @var{exp} @ - [#:system (%current-system)] [#:inputs '()] @ - [#:outputs '("out")] [#:hash #f] @ - [#:hash-algo #f] [#:env-vars '()] [#:modules '()] @ - [#:references-graphs #f] [#:guile-for-build #f] -Monadic version of @code{build-expression->derivation} -(@pxref{Derivations}). -@end deffn - @deffn {Monadic Procedure} package->derivation @var{package} [@var{system}] Monadic version of @code{package-derivation} (@pxref{Defining Packages}). diff --git a/guix/gexp.scm b/guix/gexp.scm index 9dd83f5370..01084c2620 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -66,10 +66,9 @@ (define raw-derivation (store-lift derivation)) -(define (lower-inputs* inputs) +(define (lower-inputs inputs) "Turn any package from INPUTS into a derivation; return the corresponding input list as a monadic value." - ;; XXX: This is like 'lower-inputs' but without the "name" part in tuples. (with-monad %store-monad (sequence %store-monad (map (match-lambda @@ -101,7 +100,7 @@ The other arguments are as for 'derivation'." (define %modules modules) (define outputs (gexp-outputs exp)) - (mlet* %store-monad ((inputs (lower-inputs* (gexp-inputs exp))) + (mlet* %store-monad ((inputs (lower-inputs (gexp-inputs exp))) (sexp (gexp->sexp exp #:outputs outputs)) (builder (text-file (string-append name "-builder") (object->string sexp))) diff --git a/guix/monads.scm b/guix/monads.scm index db8b645402..0e99cb37f1 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -57,9 +57,7 @@ text-file* package-file package->derivation - built-derivations - derivation-expression - lower-inputs) + built-derivations) #:replace (imported-modules compiled-modules)) @@ -356,6 +354,7 @@ and store file names; the resulting store file holds references to all these." (lambda (port) (display ,(computed-text text inputs) port)))) + ;; TODO: Rewrite using 'gexp->derivation'. (mlet %store-monad ((inputs (lower-inputs inputs))) (derivation-expression name (builder inputs) #:inputs inputs))) @@ -376,7 +375,7 @@ OUTPUT directory of PACKAGE." (define (lower-inputs inputs) "Turn any package from INPUTS into a derivation; return the corresponding input list as a monadic value." - ;; XXX: Should probably be in (guix packages). + ;; XXX: This procedure is bound to disappear with 'derivation-expression'. (with-monad %store-monad (sequence %store-monad (map (match-lambda @@ -390,6 +389,7 @@ input list as a monadic value." inputs)))) (define derivation-expression + ;; XXX: This procedure is superseded by 'gexp->derivation'. (store-lift build-expression->derivation)) (define package->derivation diff --git a/guix/ui.scm b/guix/ui.scm index 944c9f87fa..259dddd481 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -241,7 +241,7 @@ interpreted." str args))))) (catch #t (lambda () - (eval exp the-scm-module)) + (eval exp the-root-module)) (lambda args (leave (_ "failed to evaluate expression `~a': ~s~%") exp args))))) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index d66e132c1f..e0c774d055 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013 Ludovic Courtès +# Copyright © 2012, 2013, 2014 Ludovic Courtès # # This file is part of GNU Guix. # @@ -75,7 +75,8 @@ then false; else true; fi # Invoking a monadic procedure. guix build -e "(begin - (use-modules (guix monads) (guix utils)) + (use-modules (guix gexp)) (lambda () - (derivation-expression \"test\" '(mkdir %output))))" \ + (gexp->derivation \"test\" + (gexp (mkdir (ungexp output))))))" \ --dry-run diff --git a/tests/monads.scm b/tests/monads.scm index b51e705f01..82f4b9989c 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -108,6 +108,9 @@ guile))) #:guile-for-build (package-derivation %store %bootstrap-guile))) +(define derivation-expression + (@@ (guix monads) derivation-expression)) + (test-assert "mlet* + derivation-expression" (run-with-store %store (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile")) -- cgit v1.2.3 From b6c18d6af7862847326db290e890a7327203b282 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Apr 2014 23:52:13 +0200 Subject: gnu: mcron: Upgrade to 1.0.7. * gnu/packages/guile.scm (mcron): Upgrade to 1.0.7. Use GUILE-2.0 instead of GUILE-1.8; add 'native-inputs' field. --- gnu/packages/guile.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm index a240937f75..656f22c7e6 100644 --- a/gnu/packages/guile.scm +++ b/gnu/packages/guile.scm @@ -271,18 +271,18 @@ library.") (define-public mcron (package (name "mcron") - (version "1.0.6") + (version "1.0.7") (source (origin (method url-fetch) (uri (string-append "mirror://gnu/mcron/mcron-" version ".tar.gz")) (sha256 (base32 - "0yvrfzzdy2m7fbqkr61fw01wd9r2jpnbyabxhcsfivgxywknl0fy")) + "1d214fmhsn3kvpnwxnqwfpy6gr5c5dbz2mx3sijhxi070vkfibxc")) (patches (list (search-patch "mcron-install.patch"))))) (build-system gnu-build-system) - (inputs - `(("ed" ,ed) ("which" ,which) ("guile" ,guile-1.8))) + (native-inputs `(("pkg-config" ,pkg-config))) + (inputs `(("ed" ,ed) ("which" ,which) ("guile" ,guile-2.0))) (home-page "http://www.gnu.org/software/mcron/") (synopsis "Run jobs at scheduled times") (description -- cgit v1.2.3 From 6d7b4206d73d2a072e394f24e22ba9aded8f65ad Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Apr 2014 23:53:01 +0200 Subject: gnu: screen: Upgrade to 4.2.1. * gnu/packages/screen.scm (screen): Upgrade to 4.2.1. --- gnu/packages/screen.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/screen.scm b/gnu/packages/screen.scm index 58ee42a2a2..ae03220cc3 100644 --- a/gnu/packages/screen.scm +++ b/gnu/packages/screen.scm @@ -29,13 +29,13 @@ (define-public screen (package (name "screen") - (version "4.0.3") + (version "4.2.1") (source (origin (method url-fetch) (uri (string-append "mirror://gnu/screen/screen-" version ".tar.gz")) (sha256 - (base32 "0xvckv1ia5pjxk7fs4za6gz2njwmfd54sc464n8ab13096qxbw3q")))) + (base32 "105hp6qdd8rl71p81klmxiz4mlb60kh9r7czayrx40g38x858s2l")))) (build-system gnu-build-system) (inputs `(("ncurses", ncurses) -- cgit v1.2.3 From bfd9eed9557605ad6ee9339d649b57f183d90628 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Apr 2014 17:58:34 +0200 Subject: gexp: Remove leftover parameter. * guix/gexp.scm (gexp->sexp): Remove #:outputs parameter. Adjust callers accordingly. --- guix/gexp.scm | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index 01084c2620..a52360cd11 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -101,7 +101,7 @@ The other arguments are as for 'derivation'." (define outputs (gexp-outputs exp)) (mlet* %store-monad ((inputs (lower-inputs (gexp-inputs exp))) - (sexp (gexp->sexp exp #:outputs outputs)) + (sexp (gexp->sexp exp)) (builder (text-file (string-append name "-builder") (object->string sexp))) (modules (if (pair? %modules) @@ -179,7 +179,7 @@ The other arguments are as for 'derivation'." '() (gexp-references exp))) -(define* (gexp->sexp exp #:key (outputs '())) +(define* (gexp->sexp exp) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" (define (reference->sexp ref) @@ -190,13 +190,12 @@ and in the current monad setting (system type, etc.)" (((? package? p) (? string? output)) (package-file p #:output output)) (($ output) - (match (member output outputs) - (#f - (error "no such output" output)) - (_ - (return `((@ (guile) getenv) ,output))))) + ;; Output file names are not known in advance but the daemon defines + ;; an environment variable for each of them at build time, so use + ;; that trick. + (return `((@ (guile) getenv) ,output))) ((? gexp? exp) - (gexp->sexp exp #:outputs outputs)) + (gexp->sexp exp)) (((? string? str)) (return (if (direct-store-path? str) str ref))) ((refs ...) -- cgit v1.2.3 From 0423b7847baccf630349a5fc6bfa3317936467ef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Apr 2014 17:59:23 +0200 Subject: Update 'TODO'. --- TODO | 26 -------------------------- 1 file changed, 26 deletions(-) diff --git a/TODO b/TODO index 0d52633556..ee5bc7fd2d 100644 --- a/TODO +++ b/TODO @@ -63,32 +63,6 @@ create a new ‘dir’. ("i3" ,p3))) #+END_SRC -* MAYBE use HOP-like escapes to refer to inputs in build-side code - -Instead of doing things like: - -#+BEGIN_SRC scheme - (inputs `(("foo" ,foo))) - (arguments '(#:configure-flags - (list (string-append "--with-foo=" - (assoc-ref %build-inputs "foo"))))) -#+END_SRC - -Allow things like: - -#+BEGIN_SRC scheme - (inputs (list foo)) - (arguments ~(#:configure-flags - (list (string-append "--with-foo=" $foo)))) - -#+END_SRC - -... where '~' is 'build-quote' and '$' is 'build-unquote'. Better yet, -automatically compute the list of references of an expression passed to -'derivation-expression'. - -Use a [[http://dorophone.blogspot.fr/2011/09/scheme-syntax-is-monad.html][monad]] for the syntax. - * synchronize non-GNU package descriptions with the [[http://directory.fsf.org][FSD]] Meta-data for GNU packages, including descriptions and synopses, can be -- cgit v1.2.3 From 187eb5f6430c5b8ba1dc1853e97533551f932b61 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Apr 2014 18:02:16 +0200 Subject: gnu-maintenance: Avoid network access in 'gnu-package?'. * guix/gnu-maintenance.scm (gnu-package?): Add 'mirror-type' procedure. Resort to 'official-gnu-packages' only when 'mirror-type' returns #f. --- guix/gnu-maintenance.scm | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 14195da7ba..d8b6af9d31 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -167,13 +167,22 @@ (lambda (package) "Return true if PACKAGE is a GNU package. This procedure may access the network to check in GNU's database." - ;; TODO: Find a way to determine that a package is non-GNU without going - ;; through the network. + (define (mirror-type url) + (let ((uri (string->uri url))) + (and (eq? (uri-scheme uri) 'mirror) + (if (member (uri-host uri) '("gnu" "gnupg" "gcc")) + 'gnu + 'non-gnu)))) + (let ((url (and=> (package-source package) origin-uri)) (name (package-name package))) - (or (and (string? url) (string-prefix? "mirror://gnu" url)) - (and (member name (map gnu-package-name (official-gnu-packages))) - #t))))))) + (case (and url (mirror-type url)) + ((gnu) #t) + ((non-gnu) #f) + (else + ;; Last resort: resort to the network. + (and (member name (map gnu-package-name (official-gnu-packages))) + #t)))))))) ;;; -- cgit v1.2.3 From 2c6b7c7d55772be745e8cc615a0868ccc2182e62 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Apr 2014 18:05:52 +0200 Subject: gnu: guile-ncurses: Build with Unicode support. * gnu/packages/guile.scm (guile-ncurses)[arguments]: Pass "--with-ncursesw". --- gnu/packages/guile.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm index 656f22c7e6..4c42d82345 100644 --- a/gnu/packages/guile.scm +++ b/gnu/packages/guile.scm @@ -247,7 +247,8 @@ many readers as needed).") (inputs `(("ncurses" ,ncurses) ("guile" ,guile-2.0))) (arguments - '(#:configure-flags (list (string-append "--with-guilesitedir=" + '(#:configure-flags (list "--with-ncursesw" ; Unicode support + (string-append "--with-guilesitedir=" (assoc-ref %outputs "out") "/share/guile/site/2.0")) #:phases (alist-cons-after -- cgit v1.2.3 From be4e38fb6f8f2da9de4f9c6ff9e448a9dc178c8d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Apr 2014 18:13:10 +0200 Subject: derivations: Micro-optimize 'derivation'. * guix/derivations.scm (derivation->string): New procedure. (derivation-hash, derivation): Use it. Memoization here yields a 5% improvement on "guix build -e '(@ (gnu packages emacs) emacs)' -n --no-substitutes". --- guix/derivations.scm | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/guix/derivations.scm b/guix/derivations.scm index a3a4eae6ac..09b7ec079e 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -435,6 +435,14 @@ that form." port) (display ")" port)))) +(define derivation->string + (memoize + (lambda (drv) + "Return the external representation of DRV as a string." + (with-fluids ((%default-port-encoding "UTF-8")) + (call-with-output-string + (cut write-derivation drv <>)))))) + (define* (derivation->output-path drv #:optional (output "out")) "Return the store path of its output OUTPUT." (let ((outputs (derivation-outputs drv))) @@ -517,9 +525,7 @@ in SIZE bytes." ;; the SHA256 port's `write' method gets called for every single ;; character. (sha256 - (with-fluids ((%default-port-encoding "UTF-8")) - (string->utf8 (call-with-output-string - (cut write-derivation drv <>))))))))))) + (string->utf8 (derivation->string drv))))))))) (define (store-path type hash name) ; makeStorePath "Return the store path for NAME/HASH/TYPE." @@ -685,8 +691,7 @@ derivations where the costs of data transfers would outweigh the benefits." (drv (add-output-paths drv-masked))) (let ((file (add-text-to-store store (string-append name ".drv") - (call-with-output-string - (cut write-derivation drv <>)) + (derivation->string drv) (map derivation-input-path inputs)))) (set-file-name drv file)))) -- cgit v1.2.3 From 3de01d3fa1772ee3dc217fb1464b8b2cce3e9178 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 24 Apr 2014 15:13:59 -0500 Subject: gnu: Add gmsh * gnu/packages/maths.scm (gmsh): New variable --- gnu/packages/maths.scm | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 232b79b312..1bbd2360de 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -26,9 +26,13 @@ #:use-module (guix download) #:use-module (guix build-system cmake) #:use-module (guix build-system gnu) + #:use-module (gnu packages algebra) + #:use-module (gnu packages bison) + #:use-module (gnu packages cmake) #:use-module (gnu packages compression) #:use-module (gnu packages curl) #:use-module (gnu packages elf) + #:use-module (gnu packages flex) #:use-module (gnu packages fltk) #:use-module (gnu packages fontutils) #:use-module (gnu packages gettext) @@ -320,3 +324,45 @@ applications and it provides great support for visualizing results. Work may be performed both at the interactive command-line as well as via script files.") (license license:gpl3+))) + +(define-public gmsh + (package + (name "gmsh") + (version "2.8.4") + (source + (origin + (method url-fetch) + (uri (string-append "http://www.geuz.org/gmsh/src/gmsh-" + version "-source.tgz")) + (sha256 + (base32 "0jv2yvk28w86rx5mvjkb0w12ff2jxih7axnpvznpd295lg5jg7hr")) + (modules '((guix build utils))) + (snippet + ;; Remove non-free METIS code + '(delete-file-recursively "contrib/Metis")))) + (build-system cmake-build-system) + (native-inputs `(("patchelf" ,patchelf))) ;for augment-rpath + (propagated-inputs + `(("fltk" ,fltk) + ("gfortran" ,gfortran-4.8) + ("gmp" ,gmp) + ("hdf5-lib" ,hdf5 "lib") + ("hdf5-include" ,hdf5 "include") + ("lapack" ,lapack) + ("mesa" ,mesa) + ("libx11" ,libx11) + ("libxext" ,libxext))) + (arguments + `(#:configure-flags `("-DENABLE_METIS:BOOL=OFF" + "-DENABLE_BUILD_SHARED:BOOL=ON" + "-DENABLE_BUILD_DYNAMIC:BOOL=ON"))) + (home-page "http://www.geuz.org/gmsh/") + (synopsis "3D finite element grid generator") + (description "Gmsh is a 3D finite element grid generator with a build-in +CAD engine and post-processor. Its design goal is to provide a fast, light and +user-friendly meshing tool with parametric input and advanced visualization +capabilities. Gmsh is built around four modules: geometry, mesh, solver and +post-processing. The specification of any input to these modules is done +either interactively using the graphical user interface or in ASCII text files +using Gmsh's own scripting language.") + (license license:gpl2+))) -- cgit v1.2.3 From edf684ef9993d2c1e64a0bf0b8931608d7a0caf4 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Wed, 30 Apr 2014 14:56:52 -0500 Subject: gnu: gmsh: Fix typos * gnu/packages/maths.scm (gmsh): Fix typo and space aftern end-of-sentence. --- gnu/packages/maths.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 1bbd2360de..03f6be120b 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -358,11 +358,11 @@ files.") "-DENABLE_BUILD_DYNAMIC:BOOL=ON"))) (home-page "http://www.geuz.org/gmsh/") (synopsis "3D finite element grid generator") - (description "Gmsh is a 3D finite element grid generator with a build-in -CAD engine and post-processor. Its design goal is to provide a fast, light and -user-friendly meshing tool with parametric input and advanced visualization -capabilities. Gmsh is built around four modules: geometry, mesh, solver and -post-processing. The specification of any input to these modules is done -either interactively using the graphical user interface or in ASCII text files -using Gmsh's own scripting language.") + (description "Gmsh is a 3D finite element grid generator with a built-in +CAD engine and post-processor. Its design goal is to provide a fast, light +and user-friendly meshing tool with parametric input and advanced +visualization capabilities. Gmsh is built around four modules: geometry, +mesh, solver and post-processing. The specification of any input to these +modules is done either interactively using the graphical user interface or in +ASCII text files using Gmsh's own scripting language.") (license license:gpl2+))) -- cgit v1.2.3 From 864068e204faaba44efee940a079ab2a16ba9909 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Wed, 30 Apr 2014 15:12:43 -0500 Subject: gnu: calcurse: Fix module definition. * gnu/packages/calcurse.scm: Define calcurse module correctly. --- gnu/packages/calcurse.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnu/packages/calcurse.scm b/gnu/packages/calcurse.scm index 84dab0c53c..c13cfeaa37 100644 --- a/gnu/packages/calcurse.scm +++ b/gnu/packages/calcurse.scm @@ -16,7 +16,7 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . -(define-module (gnu packages autogen) +(define-module (gnu packages calcurse) #:use-module (guix packages) #:use-module (guix licenses) #:use-module (guix download) -- cgit v1.2.3 From 4dfe6c58ee204cf05ce9ef5abbc96ada44ef0784 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Apr 2014 15:44:59 +0200 Subject: system: Add (guix build activation). * gnu/services/dmd.scm (dmd-configuration-file): Remove 'etc' parameter. Move /etc activation code to... * guix/build/activation.scm: ... here; new file. * gnu/system.scm (operating-system-boot-script): Augment script: add (guix build activation) to the load path; call 'activate-etc'. * Makefile.am (MODULES): Add guix/build/activation.scm. --- Makefile.am | 1 + gnu/services/dmd.scm | 27 ++------------------ gnu/system.scm | 21 +++++++++++++--- guix/build/activation.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 84 insertions(+), 28 deletions(-) create mode 100644 guix/build/activation.scm diff --git a/Makefile.am b/Makefile.am index d01032f530..22bbdca13c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -71,6 +71,7 @@ MODULES = \ guix/build/rpath.scm \ guix/build/svn.scm \ guix/build/vm.scm \ + guix/build/activation.scm \ guix/packages.scm \ guix/snix.scm \ guix/scripts/download.scm \ diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index c187c09857..161a971edd 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -30,9 +30,8 @@ ;;; ;;; Code: -(define (dmd-configuration-file services etc) - "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC (the derivation that builds the /etc directory) on startup." +(define (dmd-configuration-file services) + "Return the dmd configuration file for SERVICES." (define config #~(begin (use-modules (ice-9 ftw)) @@ -48,28 +47,6 @@ ETC (the derivation that builds the /etc directory) on startup." #:stop #$(service-stop service))) services)) - ;; /etc is a mixture of static and dynamic settings. Here is where we - ;; initialize it from the static part. - (format #t "populating /etc from ~a...~%" #$etc) - (let ((rm-f (lambda (f) - (false-if-exception (delete-file f))))) - (rm-f "/etc/static") - (symlink #$etc "/etc/static") - (for-each (lambda (file) - ;; TODO: Handle 'shadow' specially so that changed - ;; password aren't lost. - (let ((target (string-append "/etc/" file)) - (source (string-append "/etc/static/" file))) - (rm-f target) - (symlink source target))) - (scandir #$etc - (lambda (file) - (not (member file '("." "..")))))) - - ;; Prevent ETC from being GC'd. - (rm-f "/var/guix/gcroots/etc-directory") - (symlink #$etc "/var/guix/gcroots/etc-directory")) - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. (setenv "PATH" "/run/current-system/bin") diff --git a/gnu/system.scm b/gnu/system.scm index 86904d9be2..4a85857582 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -256,10 +256,25 @@ we're running in the final root." (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (dmd-conf (dmd-configuration-file services etc))) + (modules (imported-modules '((guix build activation)))) + (compiled (compiled-modules '((guix build activation)))) + (dmd-conf (dmd-configuration-file services))) (gexp->file "boot" - #~(execl (string-append #$dmd "/bin/dmd") - "dmd" "--config" #$dmd-conf)))) + #~(begin + (eval-when (expand load eval) + ;; Make sure 'use-modules' below succeeds. + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons #$compiled %load-compiled-path))) + + (use-modules (guix build activation)) + + ;; Populate /etc. + (activate-etc #$etc) + + ;; Start dmd. + (execl (string-append #$dmd "/bin/dmd") + "dmd" "--config" #$dmd-conf))))) (define (operating-system-derivation os) "Return a derivation that builds OS." diff --git a/guix/build/activation.scm b/guix/build/activation.scm new file mode 100644 index 0000000000..c8491677d3 --- /dev/null +++ b/guix/build/activation.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix build activation) + #:use-module (ice-9 ftw) + #:export (activate-etc)) + +;;; Commentary: +;;; +;;; This module provides "activation" helpers. Activation is the process that +;;; consists in setting up system-wide files and directories so that an +;;; 'operating-system' configuration becomes active. +;;; +;;; Code: + +(define (activate-etc etc) + "Install ETC, a directory in the store, as the source of static files for +/etc." + + ;; /etc is a mixture of static and dynamic settings. Here is where we + ;; initialize it from the static part. + + (format #t "populating /etc from ~a...~%" etc) + (let ((rm-f (lambda (f) + (false-if-exception (delete-file f))))) + (rm-f "/etc/static") + (symlink etc "/etc/static") + (for-each (lambda (file) + ;; TODO: Handle 'shadow' specially so that changed + ;; password aren't lost. + (let ((target (string-append "/etc/" file)) + (source (string-append "/etc/static/" file))) + (rm-f target) + (symlink source target))) + (scandir etc + (lambda (file) + (not (member file '("." "..")))) + + ;; The default is 'string-locale Date: Wed, 30 Apr 2014 22:11:01 +0200 Subject: linux-initrd: Allow setuid binaries from the unionfs to run. * guix/build/linux-initrd.scm (boot-system): Pass the 'suid' option to UNIONFS. --- guix/build/linux-initrd.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 5d4446e720..4decc3b15c 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -290,7 +290,7 @@ to it are lost." ;; Make /root a union of the tmpfs and the actual root. (unless (zero? (system* unionfs "-o" - "cow,allow_other,use_ino,dev" + "cow,allow_other,use_ino,suid,dev" "/rw-root=RW:/real-root=RO" "/root")) (error "unionfs failed"))) -- cgit v1.2.3 From 09e028f45feca1c415cd961ac5c79e5c7d5f3ae7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Apr 2014 22:17:56 +0200 Subject: system: Add support for setuid binaries. * gnu/system.scm ()[pam-services, setuid-programs]: New fields. (etc-directory)[bashrc]: Prepend /run/setuid-programs to $PATH. (operating-system-etc-directory): Honor 'operating-system-pam-services'. (%setuid-programs): New variable. (operating-system-boot-script): Add (guix build utils) to the set of imported modules. Call 'activate-setuid-programs' in boot script. * gnu/system/linux.scm (base-pam-services): New procedure. * guix/build/activation.scm (%setuid-directory): New variable. (activate-setuid-programs): New procedure. * build-aux/hydra/demo-os.scm: Add 'pam-services' field. --- build-aux/hydra/demo-os.scm | 4 ++++ gnu/system.scm | 33 ++++++++++++++++++++++++++++----- gnu/system/linux.scm | 11 +++++++++-- guix/build/activation.scm | 36 +++++++++++++++++++++++++++++++++++- 4 files changed, 76 insertions(+), 8 deletions(-) diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index c2ff012a1b..3987c4048d 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -34,6 +34,7 @@ (gnu packages package-management) (gnu system shadow) ; 'user-account' + (gnu system linux) ; 'base-pam-services' (gnu services base) (gnu services networking) (gnu services xorg)) @@ -56,6 +57,9 @@ #:gateway "10.0.2.2") %base-services)) + (pam-services + ;; Explicitly allow for empty passwords. + (base-pam-services #:allow-empty-passwords? #t)) (packages (list bash coreutils findutils grep sed procps psmisc less guile-2.0 dmd guix util-linux inetutils diff --git a/gnu/system.scm b/gnu/system.scm index 4a85857582..ba105e2df1 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -106,7 +106,12 @@ (locale operating-system-locale) ; string (services operating-system-services ; list of monadic services - (default %base-services))) + (default %base-services)) + + (pam-services operating-system-pam-services ; list of PAM services + (default (base-pam-services))) + (setuid-programs operating-system-setuid-programs + (default %setuid-programs))) ; list of string-valued gexps @@ -191,6 +196,7 @@ export TZ=\"" timezone "\" export TZDIR=\"" tzdata "/share/zoneinfo\" export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin +export PATH=/run/setuid-programs:$PATH export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' @@ -238,8 +244,8 @@ alias ll='ls -l' (pam-services -> ;; Services known to PAM. (delete-duplicates - (cons %pam-other-services - (append-map service-pam-services services)))) + (append (operating-system-pam-services os) + (append-map service-pam-services services)))) (accounts (operating-system-accounts os)) (profile-drv (operating-system-profile os)) (groups -> (append (operating-system-groups os) @@ -250,15 +256,29 @@ alias ll='ls -l' #:timezone (operating-system-timezone os) #:profile profile-drv))) +(define %setuid-programs + ;; Default set of setuid-root programs. + (let ((shadow (@ (gnu packages admin) shadow))) + (list #~(string-append #$shadow "/bin/passwd") + #~(string-append #$shadow "/bin/su") + #~(string-append #$inetutils "/bin/ping")))) + (define (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root." + (define %modules + '((guix build activation) + (guix build utils))) + (mlet* %store-monad ((services (sequence %store-monad (operating-system-services os))) (etc (operating-system-etc-directory os)) - (modules (imported-modules '((guix build activation)))) - (compiled (compiled-modules '((guix build activation)))) + (modules (imported-modules %modules)) + (compiled (compiled-modules %modules)) (dmd-conf (dmd-configuration-file services))) + (define setuid-progs + (operating-system-setuid-programs os)) + (gexp->file "boot" #~(begin (eval-when (expand load eval) @@ -272,6 +292,9 @@ we're running in the final root." ;; Populate /etc. (activate-etc #$etc) + ;; Activate setuid programs. + (activate-setuid-programs (list #$@setuid-progs)) + ;; Start dmd. (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index efe27c55c3..4030d8860e 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -29,8 +29,8 @@ #:export (pam-service pam-entry pam-services->directory - %pam-other-services - unix-pam-service)) + unix-pam-service + base-pam-services)) ;;; Commentary: ;;; @@ -152,4 +152,11 @@ should be the name of a file used as the message-of-the-day." (list #~(string-append "motd=" #$motd))))) (list unix)))))))) +(define* (base-pam-services #:key allow-empty-passwords?) + "Return the list of basic PAM services everyone would want." + (list %pam-other-services + (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?) + (unix-pam-service "passwd" + #:allow-empty-passwords? allow-empty-passwords?))) + ;;; linux.scm ends here diff --git a/guix/build/activation.scm b/guix/build/activation.scm index c8491677d3..6930a8c585 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -17,8 +17,10 @@ ;;; along with GNU Guix. If not, see . (define-module (guix build activation) + #:use-module (guix build utils) #:use-module (ice-9 ftw) - #:export (activate-etc)) + #:export (activate-etc + activate-setuid-programs)) ;;; Commentary: ;;; @@ -60,4 +62,36 @@ (rm-f "/var/guix/gcroots/etc-directory") (symlink etc "/var/guix/gcroots/etc-directory"))) +(define %setuid-directory + ;; Place where setuid programs are stored. + "/run/setuid-programs") + +(define (activate-setuid-programs programs) + "Turn PROGRAMS, a list of file names, into setuid programs stored under +%SETUID-DIRECTORY." + (define (make-setuid-program prog) + (let ((target (string-append %setuid-directory + "/" (basename prog)))) + (catch 'system-error + (lambda () + (link prog target)) + (lambda args + ;; Perhaps PROG and TARGET live in a different file system, so copy + ;; PROG. + (copy-file prog target))) + (chown target 0 0) + (chmod target #o6555))) + + (format #t "setting up setuid programs in '~a'...~%" + %setuid-directory) + (if (file-exists? %setuid-directory) + (for-each delete-file + (scandir %setuid-directory + (lambda (file) + (not (member file '("." "..")))) + string Date: Wed, 30 Apr 2014 23:15:22 +0200 Subject: gnu: Add sudo. * gnu/packages/admin.scm (sudo): New variable. --- gnu/packages/admin.scm | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm index dd3ba33666..57fc645ad3 100644 --- a/gnu/packages/admin.scm +++ b/gnu/packages/admin.scm @@ -47,6 +47,7 @@ #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) #:use-module (gnu packages texinfo) + #:use-module (gnu packages groff) #:use-module (gnu packages xorg)) (define-public dmd @@ -619,3 +620,54 @@ according to a given schedule. It can also be used to automatically compress and archive such logs. Rot[t]log will mail reports of its activity to the system administrator.") (license gpl3+))) + +(define-public sudo + (package + (name "sudo") + (version "1.8.10p2") + (source (origin + (method url-fetch) + (uri + (list (string-append "http://www.sudo.ws/sudo/dist/sudo-" + version ".tar.gz") + (string-append "ftp://ftp.sudo.ws/pub/sudo/OLD/sudo-" + version ".tar.gz"))) + (sha256 + (base32 + "1wbrygz584abmywklq0b4xhqn3s1bjk3rrladslr5nycdpdvhv5s")))) + (build-system gnu-build-system) + (arguments + '(#:configure-flags '("--with-logpath=/var/log/sudo.log") + #:phases (alist-cons-before + 'configure 'pre-configure + (lambda _ + (substitute* "configure" + ;; Refer to the right executables. + (("/usr/bin/mv") (which "mv")) + (("/usr/bin/sh") (which "sh"))) + (substitute* (find-files "." "Makefile\\.in") + (("-O [[:graph:]]+ -G [[:graph:]]+") + ;; Allow installation as non-root. + "") + (("^install: (.*)install-sudoers(.*)" _ before after) + ;; Don't try to create /etc/sudoers. + (string-append "install: " before after "\n")))) + %standard-phases) + + ;; XXX: The 'testsudoers' test series expects user 'root' to exist, but + ;; the chroot's /etc/passwd doesn't have it. Turn off the tests. + #:tests? #f)) + (inputs + `(("groff" ,groff) + ("linux-pam" ,linux-pam) + ("coreutils" ,coreutils))) + (home-page "http://www.sudo.ws/") + (synopsis "Run commands as root") + (description + "Sudo (su \"do\") allows a system administrator to delegate authority to +give certain users (or groups of users) the ability to run some (or all) +commands as root or another user while providing an audit trail of the +commands and their arguments.") + + ;; See . + (license x11))) -- cgit v1.2.3 From 7560b00b1c9f24ceff7a9295ac3453594b14242d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 30 Apr 2014 23:16:03 +0200 Subject: gexp: Add pretty printer. * guix/gexp.scm (write-gexp): New procedure. : Add call to 'set-record-type-printer!'. --- guix/gexp.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/guix/gexp.scm b/guix/gexp.scm index a52360cd11..79b6ec7085 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -26,6 +26,7 @@ #:use-module (guix packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (gexp @@ -56,6 +57,15 @@ (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) (proc gexp-proc)) ; procedure +(define (write-gexp gexp port) + "Write GEXP on PORT." + (display "#" + (number->string (object-address gexp) 16))) + +(set-record-type-printer! write-gexp) + ;; Reference to one of the derivation's outputs, for gexps used in ;; derivations. (define-record-type -- cgit v1.2.3 From 586b6d4d45bfbf684a7a4299934d371b8b287665 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 30 Apr 2014 20:35:45 -0400 Subject: gnu: Propagate necessary inputs for sdl-image. * gnu/packages/sdl.scm (sdl-image): Propagate jpeg, png, and tiff libraries. --- gnu/packages/sdl.scm | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/gnu/packages/sdl.scm b/gnu/packages/sdl.scm index d86ecde38e..bbf8597c7a 100644 --- a/gnu/packages/sdl.scm +++ b/gnu/packages/sdl.scm @@ -147,12 +147,17 @@ other supporting functions for SDL.") (base32 "16an9slbb8ci7d89wakkmyfvp7c0cval8xw4hkg0842nhhlp540b")))) (build-system gnu-build-system) + (native-inputs `(("pkg-config" ,pkg-config))) ;; FIXME: Add webp - (inputs `(("libpng" ,libpng) - ("libjpeg" ,libjpeg) - ("libtiff" ,libtiff) - ("pkg-config" ,pkg-config))) - (propagated-inputs `(("sdl" ,sdl))) + ;; + ;; libjpeg, libpng, and libtiff are propagated inputs because the + ;; SDL_image headers include the headers of these libraries. SDL is a + ;; propagated input because the pkg-config file refers to SDL's pkg-config + ;; file. + (propagated-inputs `(("sdl" ,sdl) + ("libjpeg" ,libjpeg) + ("libpng" ,libpng) + ("libtiff" ,libtiff))) (synopsis "SDL image loading library") (description "SDL_image is an image file loading library for SDL that supports the following formats: BMP, GIF, JPEG, LBM, PCX, PNG, PNM, TGA, TIFF, -- cgit v1.2.3 From 3da5dca34c39b209787bc583c16fbe76333c2f4e Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 30 Apr 2014 20:36:32 -0400 Subject: gnu: Add abbaye. * gnu/packages/games.scm (abbaye): New variable. --- gnu/packages/games.scm | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 64 insertions(+) diff --git a/gnu/packages/games.scm b/gnu/packages/games.scm index 46fbd21805..0e5616cd59 100644 --- a/gnu/packages/games.scm +++ b/gnu/packages/games.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 John Darrington +;;; Copyright © 2014 David Thompson ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ #:use-module (gnu packages xorg) #:use-module (gnu packages pkg-config) #:use-module (gnu packages sqlite) + #:use-module (gnu packages sdl) #:use-module (guix build-system gnu)) (define-public gnubg @@ -94,3 +96,65 @@ you to set the size of the cube (the default is 3x3) or to change the colors. You may even apply photos to the faces instead of colors. The game is scriptable with Guile.") (license gpl3+))) + +(define-public abbaye + (package + (name "abbaye") + (version "1.13") + (source + (origin + (method url-fetch) + (uri (string-append "http://abbaye-for-linux.googlecode.com/files/abbaye-for-linux-src-" + version ".tar.gz")) + (sha256 + (base32 + "1wgvckgqa2084rbskxif58wbb83xbas8s1i8s7d57xbj08ryq8rk")))) + (build-system gnu-build-system) + (arguments + '(#:modules ((ice-9 match) + (guix build gnu-build-system) + (guix build utils)) + #:phases (alist-cons-after + 'set-paths 'set-sdl-paths + (lambda* (#:key inputs outputs (search-paths '()) #:allow-other-keys) + (define input-directories + (match inputs + (((_ . dir) ...) + dir))) + ;; This package does not use pkg-config, so modify CPATH + ;; variable to point to include/SDL for SDL header files. + (set-path-environment-variable "CPATH" + '("include/SDL") + input-directories)) + (alist-cons-after + 'patch-source-shebangs 'patch-makefile + (lambda* (#:key outputs #:allow-other-keys) + ;; Replace /usr with package output directory. + (for-each (lambda (file) + (substitute* file + (("/usr") (assoc-ref outputs "out")))) + '("makefile" "src/pantallas.c" "src/comun.h"))) + (alist-cons-before + 'install 'make-install-dirs + (lambda* (#:key outputs #:allow-other-keys) + (let ((prefix (assoc-ref outputs "out"))) + ;; Create directories that the makefile assumes exist. + (mkdir-p (string-append prefix "/bin")) + (mkdir-p (string-append prefix "/share/applications")))) + ;; No configure script. + (alist-delete 'configure %standard-phases)))) + #:tests? #f)) ;; No check target. + (native-inputs `(("pkg-config" ,pkg-config))) + (inputs `(("sdl" ,sdl) + ("sdl-gfx" ,sdl-gfx) + ("sdl-image" ,sdl-image) + ("sdl-mixer" ,sdl-mixer) + ("sdl-ttf" ,sdl-ttf))) + (home-page "http://code.google.com/p/abbaye-for-linux/") + (synopsis "GNU/Linux port of the indie game \"l'Abbaye des Morts\"") + (description "L'Abbaye des Morts is a 2D platform game set in 13th century +France. The Cathars, who preach about good Christian beliefs, were being +expelled by the Catholic Church out of the Languedoc region in France. One of +them, called Jean Raymond, found an old church in which to hide, not knowing +that beneath its ruins lay buried an ancient evil.") + (license gpl3+))) -- cgit v1.2.3 From b9100e2f11a6735d37bb256ffecb947f9b7ce31f Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Wed, 30 Apr 2014 14:01:43 -0500 Subject: gnu: Add petsc * gnu/packages/maths.scm (petsc): New variable. (petsc-complex): New variable. * gnu/packages/patches/petsc-fix-threadcomm.patch: New patch. * gnu-system.am (dist_patch_DATA): Add it. --- gnu-system.am | 1 + gnu/packages/maths.scm | 89 +++++++++++++++++++++++++ gnu/packages/patches/petsc-fix-threadcomm.patch | 15 +++++ 3 files changed, 105 insertions(+) create mode 100644 gnu/packages/patches/petsc-fix-threadcomm.patch diff --git a/gnu-system.am b/gnu-system.am index c18db0dc56..0bf3eece30 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -323,6 +323,7 @@ dist_patch_DATA = \ gnu/packages/patches/patchelf-page-size.patch \ gnu/packages/patches/patchutils-xfail-gendiff-tests.patch \ gnu/packages/patches/perl-no-sys-dirs.patch \ + gnu/packages/patches/petsc-fix-threadcomm.patch \ gnu/packages/patches/plotutils-libpng-jmpbuf.patch \ gnu/packages/patches/procps-make-3.82.patch \ gnu/packages/patches/python-fix-tests.patch \ diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 03f6be120b..8ac9e461a1 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -366,3 +366,92 @@ mesh, solver and post-processing. The specification of any input to these modules is done either interactively using the graphical user interface or in ASCII text files using Gmsh's own scripting language.") (license license:gpl2+))) + +(define-public petsc + (package + (name "petsc") + (version "3.4.4") + (source + (origin + (method url-fetch) + ;; The *-lite-* tarball does not contain the *large* documentation + (uri (string-append "http://ftp.mcs.anl.gov/pub/petsc/release-snapshots/" + "petsc-lite-" version ".tar.gz")) + (sha256 + (base32 "0v5dg6dhdjpi5ianvd4mm6hsvxzv1bsxwnh9f9myag0a0d9xk9iv")) + (patches + (list (search-patch "petsc-fix-threadcomm.patch"))))) + (build-system gnu-build-system) + (native-inputs + `(("python" ,python-2) + ("perl" ,perl))) + (inputs + `(("gfortran" ,gfortran-4.8) + ("lapack" ,lapack) + ;; leaving out hdf5 and fftw, as petsc expects them to be built with mpi + ;; leaving out opengl, as configuration seems to only be for mac + )) + (arguments + `(#:test-target "test" + #:parallel-build? #f + #:configure-flags + `("--with-mpi=0" + "--with-openmp=1") + #:phases + (alist-replace + 'configure + ;; PETSc's configure script is actually a python script, so we can't + ;; run it with bash. + (lambda* (#:key outputs (configure-flags '()) + #:allow-other-keys) + (let* ((prefix (assoc-ref outputs "out")) + (flags `(,(string-append "--prefix=" prefix) + ,@configure-flags))) + (format #t "build directory: ~s~%" (getcwd)) + (format #t "configure flags: ~s~%" flags) + (zero? (apply system* "./configure" flags)))) + (alist-cons-after + 'install 'clean-local-references + ;; Try to keep installed files from leaking build directory names. + (lambda* (#:key inputs outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out")) + (fortran (assoc-ref inputs "gfortran"))) + (substitute* (map (lambda (file) + (string-append out "/" file)) + '("conf/petscvariables" + "conf/PETScConfig.cmake" + "include/petscconf.h" + "include/petscmachineinfo.h")) + (((getcwd)) out)) + ;; Make compiler references point to the store + (substitute* (string-append out "/conf/petscvariables") + (("= g(cc|\\+\\+|fortran)" _ suffix) + (string-append "= " fortran "/bin/g" suffix))) + ;; PETSc installs some build logs, which aren't necessary. + (for-each (lambda (file) + (delete-file (string-append out "/" file))) + '("conf/configure.log" + "conf/make.log" + "conf/test.log" + "conf/RDict.db" + ;; Once installed, should uninstall with Guix + "conf/uninstall.py")))) + %standard-phases)))) + (home-page "http://www.mcs.anl.gov/petsc") + (synopsis "Library to solve ODEs and algebraic equations") + (description "PETSc, pronounced PET-see (the S is silent), is a suite of +data structures and routines for the scalable (parallel) solution of +scientific applications modeled by partial differential equations.") + (license (license:bsd-style + "http://www.mcs.anl.gov/petsc/documentation/copyright.html")))) + +(define-public petsc-complex + (package (inherit petsc) + (name "petsc-complex") + (arguments + (substitute-keyword-arguments (package-arguments petsc) + ((#:configure-flags cf) + `(cons "--with-scalar-type=complex" ,cf)))) + (description + (string-append (package-description petsc) + " Complex scalar type version.")))) diff --git a/gnu/packages/patches/petsc-fix-threadcomm.patch b/gnu/packages/patches/petsc-fix-threadcomm.patch new file mode 100644 index 0000000000..3ef4f2d83d --- /dev/null +++ b/gnu/packages/patches/petsc-fix-threadcomm.patch @@ -0,0 +1,15 @@ +Fix "error: unknown type name 'cpu_set_t'". Patch submitted upstream +http://lists.mcs.anl.gov/pipermail/petsc-dev/2014-May/015345.html + +--- a/src/sys/threadcomm/impls/openmp/tcopenmp.c 2014-03-13 21:47:22.000000000 -0500 ++++ b/src/sys/threadcomm/impls/openmp/tcopenmp.c 2014-04-02 14:44:57.185170151 -0500 +@@ -1,6 +1,9 @@ + #define PETSC_DESIRE_FEATURE_TEST_MACROS + #include <../src/sys/threadcomm/impls/openmp/tcopenmpimpl.h> + #include ++#if defined(PETSC_HAVE_SCHED_CPU_SET_T) ++#include ++#endif + + PetscErrorCode PetscThreadCommGetRank_OpenMP(PetscInt *trank) + { -- cgit v1.2.3 From 696893801c9d4b83adc9a15ce60103142e7c1a79 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 May 2014 15:29:24 +0200 Subject: system: Add 'sudo' to the setuid programs, and handle /etc/sudoers. * gnu/system.scm ()[groups]: Change default to just the 'root' group. [sudoers]: New field. (etc-directory): Add #:sudoers parameter. Add 'sudoers' to the file union. (operating-system-etc-directory): Pass #:sudoers to 'etc-directory'. (%setuid-programs): Add 'sudo'. (%sudoers-specification): New variable. * gnu/system/linux.scm (base-pam-services): Add 'sudo'. * build-aux/hydra/demo-os.scm: Add 'groups' field; add 'guest' to the 'wheel' group. --- build-aux/hydra/demo-os.scm | 9 +++++++++ gnu/system.scm | 30 +++++++++++++++++++++--------- gnu/system/linux.scm | 2 ++ 3 files changed, 32 insertions(+), 9 deletions(-) diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 3987c4048d..03449abda2 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -48,6 +48,15 @@ (uid 1000) (gid 100) (comment "Guest of GNU") (home-directory "/home/guest")))) + (groups (list (user-group (name "root") (id 0)) + (user-group + (name "wheel") + (id 1) + (members '("guest"))) ; allow 'guest' to use sudo + (user-group + (name "users") + (id 100) + (members '("guest"))))) (services (cons* (slim-service #:auto-login? #t #:default-user "guest") diff --git a/gnu/system.scm b/gnu/system.scm index ba105e2df1..6c94eb90c5 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -85,11 +85,7 @@ (groups operating-system-groups ; list of user groups (default (list (user-group (name "root") - (id 0)) - (user-group - (name "users") - (id 100) - (members '("guest")))))) + (id 0))))) (packages operating-system-packages ; list of (PACKAGE OUTPUT...) (default (list coreutils ; or just PACKAGE @@ -111,8 +107,10 @@ (pam-services operating-system-pam-services ; list of PAM services (default (base-pam-services))) (setuid-programs operating-system-setuid-programs - (default %setuid-programs))) ; list of string-valued gexps + (default %setuid-programs)) ; list of string-valued gexps + (sudoers operating-system-sudoers ; /etc/sudoers contents + (default %sudoers-specification))) ;;; @@ -164,13 +162,15 @@ file." (accounts '()) (groups '()) (pam-services '()) - (profile "/var/run/current-system/profile")) + (profile "/var/run/current-system/profile") + (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad ((passwd (passwd-file accounts)) (shadow (passwd-file accounts #:shadow? #t)) (group (group-file groups)) (pam.d (pam-services->directory pam-services)) + (sudoers (text-file "sudoers" sudoers)) (login.defs (text-file "login.defs" "# Empty for now.\n")) (shells (text-file "shells" ; used by xterm and others "\ @@ -215,7 +215,9 @@ alias ll='ls -l' #$timezone)) ("passwd" ,#~#$passwd) ("shadow" ,#~#$shadow) - ("group" ,#~#$group))))) + ("group" ,#~#$group) + + ("sudoers" ,#~#$sudoers))))) (define (operating-system-profile os) "Return a derivation that builds the default profile of OS." @@ -254,6 +256,7 @@ alias ll='ls -l' #:pam-services pam-services #:locale (operating-system-locale os) #:timezone (operating-system-timezone os) + #:sudoers (operating-system-sudoers os) #:profile profile-drv))) (define %setuid-programs @@ -261,7 +264,16 @@ alias ll='ls -l' (let ((shadow (@ (gnu packages admin) shadow))) (list #~(string-append #$shadow "/bin/passwd") #~(string-append #$shadow "/bin/su") - #~(string-append #$inetutils "/bin/ping")))) + #~(string-append #$inetutils "/bin/ping") + #~(string-append #$sudo "/bin/sudo")))) + +(define %sudoers-specification + ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel' + ;; group can do anything. See + ;; . + ;; TODO: Add a declarative API. + "root ALL=(ALL) ALL +%wheel ALL=(ALL) ALL\n") (define (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 4030d8860e..3a43eb45e3 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -157,6 +157,8 @@ should be the name of a file used as the message-of-the-day." (list %pam-other-services (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?) (unix-pam-service "passwd" + #:allow-empty-passwords? allow-empty-passwords?) + (unix-pam-service "sudo" #:allow-empty-passwords? allow-empty-passwords?))) ;;; linux.scm ends here -- cgit v1.2.3 From 79c0c8cdf74cc0587187aa8f25af29b21fe91ba2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 May 2014 16:15:00 +0200 Subject: gexp: Add support for 'origin?' objects in 'ungexp' forms. * guix/gexp.scm (lower-inputs, gexp-inputs, gexp->sexp, canonicalize-reference): Add 'origin?' case. * guix/monads.scm (origin->derivation): New procedure. * tests/gexp.scm ("one input origin"): New test. --- guix/gexp.scm | 12 ++++++++++++ guix/monads.scm | 4 ++++ tests/gexp.scm | 14 ++++++++++++-- 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index 79b6ec7085..ff4fd3f289 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -85,6 +85,9 @@ input list as a monadic value." (((? package? package) sub-drv ...) (mlet %store-monad ((drv (package->derivation package))) (return `(,drv ,@sub-drv)))) + (((? origin? origin) sub-drv ...) + (mlet %store-monad ((drv (origin->derivation origin))) + (return `(,drv ,@sub-drv)))) (input (return input))) inputs)))) @@ -158,6 +161,8 @@ The other arguments are as for 'derivation'." (cons ref result)) (((? package?) (? string?)) (cons ref result)) + (((? origin?) (? string?)) + (cons ref result)) ((? gexp? exp) (append (gexp-inputs exp) result)) (((? string? file)) @@ -199,6 +204,9 @@ and in the current monad setting (system type, etc.)" (return (derivation->output-path drv output))) (((? package? p) (? string? output)) (package-file p #:output output)) + (((? origin? o) (? string? output)) + (mlet %store-monad ((drv (origin->derivation o))) + (return (derivation->output-path drv output)))) (($ output) ;; Output file names are not known in advance but the daemon defines ;; an environment variable for each of them at build time, so use @@ -224,10 +232,14 @@ package/derivation references." (match ref ((? package? p) `(,p "out")) + ((? origin? o) + `(,o "out")) ((? derivation? d) `(,d "out")) (((? package?) (? string?)) ref) + (((? origin?) (? string?)) + ref) (((? derivation?) (? string?)) ref) ((? string? s) diff --git a/guix/monads.scm b/guix/monads.scm index 0e99cb37f1..809aba59b1 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -56,6 +56,7 @@ text-file text-file* package-file + origin->derivation package->derivation built-derivations) #:replace (imported-modules @@ -395,6 +396,9 @@ input list as a monadic value." (define package->derivation (store-lift package-derivation)) +(define origin->derivation + (store-lift package-source-derivation)) + (define imported-modules (store-lift (@ (guix derivations) imported-modules))) diff --git a/tests/gexp.scm b/tests/gexp.scm index 3da5b82e4c..21606b510b 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -21,8 +21,7 @@ #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix derivations) - #:use-module ((guix packages) - #:select (package-derivation %current-system)) + #:use-module (guix packages) #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages bootstrap) @@ -83,6 +82,17 @@ (package-derivation %store coreutils))) (gexp->sexp* exp))))) +(test-assert "one input origin" + (let ((exp (gexp (display (ungexp (package-source coreutils)))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((o "out")) + (eq? o (package-source coreutils)))) + (equal? `(display ,(derivation->output-path + (package-source-derivation + %store (package-source coreutils)))) + (gexp->sexp* exp))))) + (test-assert "same input twice" (let ((exp (gexp (begin (display (ungexp coreutils)) -- cgit v1.2.3 From 53e89b1732d2935d69a199c0213568ae1e66eb60 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 May 2014 18:53:16 +0200 Subject: monads, gexp: Remove unintended dependency on (gnu packages …). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/gexp.scm (gexp->derivation, gexp->script): Use 'default-guile' instead of an explicit reference to 'guile-final'. (default-guile): New procedure. * guix/monads.scm (run-with-store)[default-guile]: New procedure. Use it. --- guix/gexp.scm | 14 +++++++++----- guix/monads.scm | 9 +++++++-- 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index ff4fd3f289..a2ba50d957 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -129,9 +129,8 @@ The other arguments are as for 'derivation'." (return #f))) (guile (if guile-for-build (return guile-for-build) - (package->derivation - (@ (gnu packages base) guile-final) - system)))) + (package->derivation (default-guile) + system)))) (raw-derivation name (string-append (derivation->output-path guile) "/bin/guile") @@ -336,9 +335,14 @@ package/derivation references." ;;; Convenience procedures. ;;; +(define (default-guile) + ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) + ;; modules directly, to avoid circular dependencies, hence this hack. + (module-ref (resolve-interface '(gnu packages base)) + 'guile-final)) + (define* (gexp->script name exp - #:key (modules '()) - (guile (@ (gnu packages base) guile-final))) + #:key (modules '()) (guile (default-guile))) "Return an executable script NAME that runs EXP using GUILE with MODULES in its search path." (mlet %store-monad ((modules (imported-modules modules)) diff --git a/guix/monads.scm b/guix/monads.scm index 809aba59b1..ec2b7f8b3b 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -414,10 +414,15 @@ input list as a monadic value." (system (%current-system))) "Run MVAL, a monadic value in the store monad, in STORE, an open store connection." + (define (default-guile) + ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) + ;; modules directly, to avoid circular dependencies, hence this hack. + (module-ref (resolve-interface '(gnu packages base)) + 'guile-final)) + (parameterize ((%guile-for-build (or guile-for-build (package-derivation store - (@ (gnu packages base) - guile-final) + (default-guile) system))) (%current-system system)) (mval store))) -- cgit v1.2.3 From 6f8f8ccb5bcc883a63c2d98463f514c9745dcb8e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 May 2014 21:07:52 +0200 Subject: download: Rewrite using gexps. * guix/download.scm (gnutls-derivation): Remove. (gnutls-package): New procedure. (url-fetch): Rewrite using 'gexp->derivation'. --- guix/download.scm | 88 ++++++++++++++++++++++++++----------------------------- 1 file changed, 41 insertions(+), 47 deletions(-) diff --git a/guix/download.scm b/guix/download.scm index 2cb0740897..8ec17ae556 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -23,6 +23,8 @@ #:use-module (guix packages) #:use-module ((guix store) #:select (derivation-path? add-to-store)) #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:)) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix utils) #:use-module (web uri) #:use-module (srfi srfi-1) @@ -167,11 +169,10 @@ "http://ftp.fr.debian.org/debian/" "http://ftp.debian.org/debian/")))) -(define (gnutls-derivation store system) - "Return the GnuTLS derivation for SYSTEM." - (let* ((module (resolve-interface '(gnu packages gnutls))) - (gnutls (module-ref module 'gnutls))) - (package-derivation store gnutls system))) +(define (gnutls-package) + "Return the GnuTLS package for SYSTEM." + (let ((module (resolve-interface '(gnu packages gnutls)))) + (module-ref module 'gnutls))) (define* (url-fetch store url hash-algo hash #:optional name @@ -186,22 +187,13 @@ different file name. When one of the URL starts with mirror://, then its host part is interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS must be a list of symbol/URL-list pairs." - (define builder - `(begin - (use-modules (guix build download)) - (url-fetch ',url %output - #:mirrors ',mirrors))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system)) - ((and (? string?) (? derivation-path?)) - guile) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages base))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system))))) + (package-derivation store + (or guile + (let ((distro + (resolve-interface '(gnu packages base)))) + (module-ref distro 'guile-final))) + system)) (define file-name (match url @@ -219,34 +211,36 @@ must be a list of symbol/URL-list pairs." ((url ...) (any https? url))))) - (let* ((gnutls-drv (if need-gnutls? - (gnutls-derivation store system) - (values #f #f))) - (gnutls (and gnutls-drv - (derivation->output-path gnutls-drv "out"))) - (env-vars (if gnutls - (let ((dir (string-append gnutls "/share/guile/site"))) - ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden - ;; by `build-expression->derivation', so we can't - ;; set it here. - `(("GUILE_LOAD_PATH" . ,dir))) - '()))) - (build-expression->derivation store (or name file-name) builder - #:system system - #:inputs (if gnutls-drv - `(("gnutls" ,gnutls-drv)) - '()) - #:hash-algo hash-algo - #:hash hash - #:modules '((guix build download) - (guix build utils) - (guix ftp-client)) - #:guile-for-build guile-for-build - #:env-vars env-vars + (define builder + #~(begin + #$(if need-gnutls? + + ;; Add GnuTLS to the inputs and to the load path. + #~(eval-when (load expand eval) + (set! %load-path + (cons (string-append #$(gnutls-package) + "/share/guile/site") + %load-path))) + #~#t) + + (use-modules (guix build download)) + (url-fetch '#$url #$output + #:mirrors '#$mirrors))) + + (run-with-store store + (gexp->derivation (or name file-name) builder + #:system system + #:hash-algo hash-algo + #:hash hash + #:modules '((guix build download) + (guix build utils) + (guix ftp-client)) + #:guile-for-build guile-for-build - ;; In general, offloading downloads is not a - ;; good idea. - #:local-build? #t))) + ;; In general, offloading downloads is not a good idea. + #:local-build? #t) + #:guile-for-build guile-for-build + #:system system)) (define* (download-to-store store url #:optional (name (basename url)) #:key (log (current-error-port))) -- cgit v1.2.3 From 6ab6ca4c9a33dd5ffb23fcc3f930772e548f14ba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 May 2014 22:04:50 +0200 Subject: gnu: qemu: Upgrade to 2.0.0. * gnu/packages/qemu.scm (qemu-headless): Upgrade to 2.0.0. --- gnu/packages/qemu.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/qemu.scm b/gnu/packages/qemu.scm index b02998392e..b4a962e888 100644 --- a/gnu/packages/qemu.scm +++ b/gnu/packages/qemu.scm @@ -44,14 +44,14 @@ ;; This is QEMU without GUI support. (package (name "qemu-headless") - (version "1.7.1") + (version "2.0.0") (source (origin (method url-fetch) (uri (string-append "http://wiki.qemu-project.org/download/qemu-" version ".tar.bz2")) (sha256 (base32 - "1x5y06zhp0gc97g1sb98vf7dkawg63xywv0mbnpfnbi20jh452fn")))) + "0frsahiw56jr4cqr9m6s383lyj4ar9hfs2wp3y4yr76krah1mk30")))) (build-system gnu-build-system) (arguments '(#:phases (alist-replace -- cgit v1.2.3 From 183e44ae4464c7219e9f65dd9c923c3bab2fd732 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Fri, 2 May 2014 10:44:50 -0500 Subject: gnu: Add superlu * gnu/packages/maths.scm (superlu): New variable --- gnu/packages/maths.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 83 insertions(+) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 8ac9e461a1..991933ad14 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -49,6 +49,7 @@ #:use-module (gnu packages pkg-config) #:use-module (gnu packages python) #:use-module (gnu packages readline) + #:use-module (gnu packages tcsh) #:use-module (gnu packages texinfo) #:use-module (gnu packages texlive) #:use-module (gnu packages xml)) @@ -455,3 +456,85 @@ scientific applications modeled by partial differential equations.") (description (string-append (package-description petsc) " Complex scalar type version.")))) + +(define-public superlu + (package + (name "superlu") + (version "4.3") + (source + (origin + (method url-fetch) + (uri (string-append "http://crd-legacy.lbl.gov/~xiaoye/SuperLU/" + "superlu_" version ".tar.gz")) + (sha256 + (base32 "10b785s9s4x0m9q7ihap09275pq4km3k2hk76jiwdfdr5qr2168n")))) + (build-system gnu-build-system) + (native-inputs + `(("tcsh" ,tcsh))) + (inputs + `(("lapack" ,lapack) + ("gfortran" ,gfortran-4.8))) + (arguments + `(#:parallel-build? #f + #:tests? #f ;tests are run as part of `make all` + #:phases + (alist-replace + 'configure + (lambda* (#:key inputs outputs #:allow-other-keys) + (call-with-output-file "make.inc" + (lambda (port) + (format port " +PLAT = +SuperLUroot = ~a +SUPERLULIB = ~a/lib/libsuperlu.a +TMGLIB = libtmglib.a +BLASDEF = -DUSE_VENDOR_BLAS +BLASLIB = -L~a/lib -lblas +LIBS = $(SUPERLULIB) $(BLASLIB) +ARCH = ar +ARCHFLAGS = cr +RANLIB = ranlib +CC = gcc +PIC = -fPIC +CFLAGS = -O3 -DPRNTlevel=0 $(PIC) +NOOPTS = -O0 $(PIC) +FORTRAN = gfortran +FFLAGS = -O2 $(PIC) +LOADER = $(CC) +CDEFS = -DAdd_" + (getcwd) + (assoc-ref outputs "out") + (assoc-ref inputs "lapack"))))) + (alist-cons-before + 'build 'create-install-directories + (lambda* (#:key outputs #:allow-other-keys) + (for-each + (lambda (dir) + (mkdir-p (string-append (assoc-ref outputs "out") + "/" dir))) + '("lib" "include"))) + (alist-replace + 'install + (lambda* (#:key outputs #:allow-other-keys) + ;; Library is placed in lib during the build phase. Copy over + ;; headers to include. + (let* ((out (assoc-ref outputs "out")) + (incdir (string-append out "/include"))) + (for-each (lambda (file) + (let ((base (basename file))) + (format #t "installing `~a' to `~a'~%" + base incdir) + (copy-file file + (string-append incdir "/" base)))) + (find-files "SRC" ".*\\.h$")))) + %standard-phases))))) + (home-page "http://crd-legacy.lbl.gov/~xiaoye/SuperLU/") + (synopsis "Supernodal direct solver for sparse linear systems") + (description + "SuperLU is a general purpose library for the direct solution of large, +sparse, nonsymmetric systems of linear equations on high performance machines. +The library is written in C and is callable from either C or Fortran. The +library routines perform an LU decomposition with partial pivoting and +triangular system solves through forward and back substitution. The library +also provides threshold-based ILU factorization preconditioners.") + (license license:bsd-3))) -- cgit v1.2.3 From f258212df5be894838fc246c387125be7fa65bc0 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Fri, 2 May 2014 14:11:37 -0500 Subject: gnu: petsc: Add input superlu. * gnu/packages/maths.scm (petsc): Configure with superlu support. --- gnu/packages/maths.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 991933ad14..99ea1c1c48 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -389,6 +389,7 @@ ASCII text files using Gmsh's own scripting language.") (inputs `(("gfortran" ,gfortran-4.8) ("lapack" ,lapack) + ("superlu" ,superlu) ;; leaving out hdf5 and fftw, as petsc expects them to be built with mpi ;; leaving out opengl, as configuration seems to only be for mac )) @@ -397,7 +398,12 @@ ASCII text files using Gmsh's own scripting language.") #:parallel-build? #f #:configure-flags `("--with-mpi=0" - "--with-openmp=1") + "--with-openmp=1" + "--with-superlu=1" + ,(string-append "--with-superlu-include=" + (assoc-ref %build-inputs "superlu") "/include") + ,(string-append "--with-superlu-lib=" + (assoc-ref %build-inputs "superlu") "/lib/libsuperlu.a")) #:phases (alist-replace 'configure -- cgit v1.2.3 From f5d5a346dbe74c93642b532a1680c900d24658d8 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Fri, 2 May 2014 14:23:16 -0500 Subject: gnu: Add missing copyright line * gnu/packages/maths.scm: Add copyright line missing from 3de01d3. --- gnu/packages/maths.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 99ea1c1c48..93ae0bd3ba 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 John Darrington +;;; Copyright © 2014 Eric Bavier ;;; ;;; This file is part of GNU Guix. ;;; -- cgit v1.2.3 From 83bcd0b895016c058807e71e102c54d2fab44339 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 00:26:07 +0200 Subject: system: Add first-class file system declarations. * gnu/system.scm ()[initrd]: Default to 'qemu-initrd'. (): New record type. (operating-system-root-file-system): New procedure. (operating-system-derivation): Take the device name for GRUB from 'operating-system-root-file-system'. Pass the 'operating-system-initrd' procedure the list of boot file systems. * gnu/system/linux-initrd.scm (file-system->spec): New procedure. (qemu-initrd): Add 'file-systems' parameter, and remove #:mounts parameter. [file-system-type-predicate]: New procedure. [linux-modules]: Use it. Adjust #:mounts argument in 'boot-system' call. (gnu-system-initrd): Remove. * gnu/system/vm.scm (%linux-vm-file-systems): New variable. (expression->derivation-in-linux-vm): Adjust call to 'qemu-initrd'. (virtualized-operating-system): New procedure. (system-qemu-image/shared-store-script)[initrd]: Remove. Use 'virtualized-operating-system'. Get the 'initrd' file from OS-DRV. * guix/build/linux-initrd.scm (mount-qemu-smb-share, mount-qemu-9p): Remove. (MS_RDONLY, MS_BIND): New global variables. (bind-mount): Remove local 'MS_BIND' definition. (mount-root-file-system): New procedure, with code formerly in 'boot-system'. (mount-file-system): New procedure. (boot-system): Add #:root-fs-type parameter. Remove 'MS_RDONLY' local variable. Use 'mount-root-file-system' and 'mount-file-system'. * doc/guix.texi (Using the Configuration System): Add 'file-system' declaration. --- .dir-locals.el | 2 + doc/guix.texi | 4 ++ gnu/system.scm | 52 ++++++++++++++++-- gnu/system/linux-initrd.scm | 47 ++++++++-------- gnu/system/vm.scm | 46 ++++++++++++---- guix/build/linux-initrd.scm | 129 ++++++++++++++++++++++---------------------- 6 files changed, 180 insertions(+), 100 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index a6135b171e..64a680c59f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -17,6 +17,8 @@ (eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'package 'scheme-indent-function 0)) (eval . (put 'origin 'scheme-indent-function 0)) + (eval . (put 'operating-system 'scheme-indent-function 0)) + (eval . (put 'file-system 'scheme-indent-function 0)) (eval . (put 'manifest-entry 'scheme-indent-function 0)) (eval . (put 'manifest-pattern 'scheme-indent-function 0)) (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index 3ae2b7e00b..99acad56e7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3088,6 +3088,10 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this: (host-name "komputilo") (timezone "Europe/Paris") (locale "fr_FR.UTF-8") + (file-systems (list (file-system + (device "/dev/disk/by-label/root") + (mount-point "/") + (type "ext3")))) (users (list (user-account (name "alice") (password "") diff --git a/gnu/system.scm b/gnu/system.scm index 6c94eb90c5..7624b10ae4 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -51,9 +51,20 @@ operating-system-timezone operating-system-locale operating-system-services + operating-system-file-systems operating-system-derivation - operating-system-profile)) + operating-system-profile + + + file-system + file-system? + file-system-device + file-system-mount-point + file-system-type + file-system-needed-for-boot? + file-system-flags + file-system-options)) ;;; Commentary: ;;; @@ -72,8 +83,8 @@ (default grub)) (bootloader-entries operating-system-bootloader-entries ; list (default '())) - (initrd operating-system-initrd ; monadic derivation - (default (gnu-system-initrd))) + (initrd operating-system-initrd ; (list fs) -> M derivation + (default qemu-initrd)) (host-name operating-system-host-name) ; string @@ -112,6 +123,22 @@ (sudoers operating-system-sudoers ; /etc/sudoers contents (default %sudoers-specification))) +;; File system declaration. +(define-record-type* file-system + make-file-system + file-system? + (device file-system-device) ; string + (mount-point file-system-mount-point) ; string + (type file-system-type) ; string + (flags file-system-flags ; list of symbols + (default '())) + (options file-system-options ; string or #f + (default #f)) + (needed-for-boot? file-system-needed-for-boot? ; Boolean + (default #f)) + (check? file-system-check? ; Boolean + (default #t))) + ;;; ;;; Derivation. @@ -311,16 +338,30 @@ we're running in the final root." (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) +(define (operating-system-root-file-system os) + "Return the root file system of OS." + (find (match-lambda + (($ _ "/") #t) + (_ #f)) + (operating-system-file-systems os))) + (define (operating-system-derivation os) "Return a derivation that builds OS." + (define boot-file-systems + (filter (match-lambda + (($ device mount-point type _ _ boot?) + (and boot? (not (string=? mount-point "/"))))) + (operating-system-file-systems os))) + (mlet* %store-monad ((profile (operating-system-profile os)) (etc (operating-system-etc-directory os)) (services (sequence %store-monad (operating-system-services os))) (boot (operating-system-boot-script os)) (kernel -> (operating-system-kernel os)) - (initrd (operating-system-initrd os)) + (initrd ((operating-system-initrd os) boot-file-systems)) (initrd-file -> #~(string-append #$initrd "/initrd")) + (root-fs -> (operating-system-root-file-system os)) (entries -> (list (menu-entry (label (string-append "GNU system with " @@ -328,7 +369,8 @@ we're running in the final root." " (technology preview)")) (linux kernel) (linux-arguments - (list "--root=/dev/sda1" + (list (string-append "--root=" + (file-system-device root-fs)) #~(string-append "--load=" #$boot))) (initrd initrd-file)))) (grub.cfg (grub-configuration-file entries))) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 6e04ad150f..8b4ab9c4eb 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -30,11 +30,12 @@ #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) + #:use-module (gnu system) ; for 'file-system' #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) #:export (expression->initrd - qemu-initrd - gnu-system-initrd)) + qemu-initrd)) ;;; Commentary: @@ -193,24 +194,29 @@ a list of Guile module names to be embedded in the initrd." (gexp->derivation name builder #:modules '((guix build utils))))) -(define* (qemu-initrd #:key +(define (file-system->spec fs) + "Return a list corresponding to file-system FS that can be passed to the +initrd code." + (match fs + (($ device mount-point type flags options) + (list device mount-point type flags options)))) + +(define* (qemu-initrd file-systems + #:key guile-modules-in-chroot? - volatile-root? - (mounts `((cifs "/store" ,(%store-prefix)) - (cifs "/xchg" "/xchg")))) + volatile-root?) "Return a monadic derivation that builds an initrd for use in a QEMU guest -where the store is shared with the host. MOUNTS is a list of file systems to -be mounted atop the root file system, where each item has the form: +where the store is shared with the host. 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'. - (FILE-SYSTEM-TYPE SOURCE TARGET) +When VOLATILE-ROOT? is true, the root file system is writable but any changes +to it are lost. 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!). - -When VOLATILE-ROOT? is true, the root file system is writable but any changes -to it are lost." +exception and backtrace!)." (define cifs-modules ;; Modules needed to mount CIFS file systems. '("md4.ko" "ecb.ko" "cifs.ko")) @@ -219,14 +225,18 @@ to it are lost." ;; Modules for the 9p paravirtualized file system. '("9pnet.ko" "9p.ko" "9pnet_virtio.ko")) + (define (file-system-type-predicate type) + (lambda (fs) + (string=? (file-system-type fs) type))) + (define linux-modules ;; Modules added to the initrd and loaded from the initrd. `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko" "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko" - ,@(if (assoc-ref mounts 'cifs) + ,@(if (find (file-system-type-predicate "cifs") file-systems) cifs-modules '()) - ,@(if (assoc-ref mounts '9p) + ,@(if (find (file-system-type-predicate "9p") file-systems) virtio-9p-modules '()) ,@(if volatile-root? @@ -238,7 +248,7 @@ to it are lost." (use-modules (guix build linux-initrd) (srfi srfi-26)) - (boot-system #:mounts '#$mounts + (boot-system #:mounts '#$(map file-system->spec file-systems) #:linux-modules '#$linux-modules #:qemu-guest-networking? #t #:guile-modules-in-chroot? '#$guile-modules-in-chroot? @@ -254,9 +264,4 @@ to it are lost." #:linux linux-libre #:linux-modules linux-modules)) -(define (gnu-system-initrd) - "Initrd for the GNU system itself, with nothing QEMU-specific." - (qemu-initrd #:guile-modules-in-chroot? #f - #:mounts '())) - ;;; linux-initrd.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index db24c4e761..c080317415 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -82,6 +82,22 @@ input tuple. The output file name is when building for SYSTEM." ((input (and (? string?) (? store-path?) file)) (return `(,input . ,file)))))) +(define %linux-vm-file-systems + ;; File systems mounted for 'derivation-in-linux-vm'. The store and /xchg + ;; directory are shared with the host over 9p. + (list (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")) + (file-system + (mount-point "/xchg") + (device "xchg") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")))) + (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) @@ -130,9 +146,8 @@ made available under the /xchg CIFS share." (coreutils -> (car (assoc-ref %final-inputs "coreutils"))) (initrd (if initrd ; use the default initrd? (return initrd) - (qemu-initrd #:guile-modules-in-chroot? #t - #:mounts `((9p "store" ,(%store-prefix)) - (9p "xchg" "/xchg")))))) + (qemu-initrd %linux-vm-file-systems + #:guile-modules-in-chroot? #t)))) (define builder ;; Code that launches the VM that evaluates EXP. @@ -292,6 +307,22 @@ system as described by OS." #:initialize-store? #t #:inputs-to-copy `(("system" ,os-drv))))) +(define (virtualized-operating-system 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 qemu-initrd <> #:volatile-root? #t)) + (file-systems (list (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext3")) + (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio")))))) + (define* (system-qemu-image/shared-store os #:key (disk-image-size (* 15 (expt 2 20)))) @@ -314,14 +345,9 @@ with the host." (graphic? #t)) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host." - (define initrd - (qemu-initrd #:mounts `((9p "store" ,(%store-prefix))) - #:volatile-root? #t)) - (mlet* %store-monad - ((os -> (operating-system (inherit os) (initrd initrd))) + ((os -> (virtualized-operating-system os)) (os-drv (operating-system-derivation os)) - (initrd initrd) (image (system-qemu-image/shared-store os))) (define builder #~(call-with-output-file #$output @@ -332,7 +358,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \ -net user \ -kernel " #$(operating-system-kernel os) "/bzImage \ - -initrd " #$initrd "/initrd \ + -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") "--load=" #$os-drv "/boot --root=/dev/vda1\" \ -drive file=" #$image diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 4decc3b15c..1e0d6e27ec 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,8 +30,7 @@ linux-command-line make-essential-device-nodes configure-qemu-networking - mount-qemu-smb-share - mount-qemu-9p + mount-file-system bind-mount load-linux-module* device-number @@ -170,33 +169,12 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." (logand (network-interface-flags sock interface) IFF_UP))) -(define (mount-qemu-smb-share share mount-point) - "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT. - -Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our -`qemu-with-multiple-smb-shares' package exports the /xchg and /store shares - (the latter allows the store to be shared between the host and guest.)" - - (format #t "mounting QEMU's SMB share `~a'...\n" share) - (let ((server "10.0.2.4")) - (mount (string-append "//" server share) mount-point "cifs" 0 - (string->pointer "guest,sec=none")))) - -(define (mount-qemu-9p source mount-point) - "Mount QEMU's 9p file system from SOURCE at MOUNT-POINT. - -This uses the 'virtio' transport, which requires the various virtio Linux -modules to be loaded." - - (format #t "mounting QEMU's 9p share '~a'...\n" source) - (let ((server "10.0.2.4")) - (mount source mount-point "9p" 0 - (string->pointer "trans=virtio")))) +;; Linux mount flags, from libc's . +(define MS_RDONLY 1) +(define MS_BIND 4096) (define (bind-mount source target) "Bind-mount SOURCE at TARGET." - (define MS_BIND 4096) ; from libc's - (mount source target "" MS_BIND)) (define (load-linux-module* file) @@ -211,11 +189,67 @@ modules to be loaded." the last argument of `mknod'." (+ (* major 256) minor)) +(define* (mount-root-file-system root type + #:key volatile-root? unionfs) + "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? +is true, mount ROOT read-only and make it a union with a writable tmpfs using +UNIONFS." + (catch #t + (lambda () + (if volatile-root? + (begin + (mkdir-p "/real-root") + (mount root "/real-root" type MS_RDONLY) + (mkdir-p "/rw-root") + (mount "none" "/rw-root" "tmpfs") + + ;; We want read-write /dev nodes. + (make-essential-device-nodes #:root "/rw-root") + + ;; Make /root a union of the tmpfs and the actual root. + (unless (zero? (system* unionfs "-o" + "cow,allow_other,use_ino,suid,dev" + "/rw-root=RW:/real-root=RO" + "/root")) + (error "unionfs failed"))) + (mount root "/root" "ext3"))) + (lambda args + (format (current-error-port) "exception while mounting '~a': ~s~%" + root args) + (start-repl)))) + +(define* (mount-file-system spec #:key (root "/root")) + "Mount the file system described by SPEC under ROOT. SPEC must have the +form: + + (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS) + +DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; +FLAGS must be a list of symbols." + (define flags->bit-mask + (match-lambda + (('read-only rest ...) + (or MS_RDONLY (flags->bit-mask rest))) + (('bind-mount rest ...) + (or MS_BIND (flags->bit-mask rest))) + (() + 0))) + + (match spec + ((source mount-point type (flags ...) options) + (let ((mount-point (string-append root "/" mount-point))) + (mkdir-p mount-point) + (mount source mount-point type (flags->bit-mask flags) + (if options + (string->pointer options) + %null-pointer)))))) + (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? volatile-root? unionfs + (root-fs-type "ext3") (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -223,9 +257,7 @@ 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'. -MOUNTS must be a list of elements of the form: - - (FILE-SYSTEM-TYPE SOURCE TARGET) +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. @@ -241,8 +273,6 @@ to it are lost." (resolve (string-append "/root" target))) file))) - (define MS_RDONLY 1) - (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") @@ -276,29 +306,9 @@ to it are lost." (unless (file-exists? "/root") (mkdir "/root")) (if root - (catch #t - (lambda () - (if volatile-root? - (begin - (mkdir-p "/real-root") - (mount root "/real-root" "ext3" MS_RDONLY) - (mkdir-p "/rw-root") - (mount "none" "/rw-root" "tmpfs") - - ;; We want read-write /dev nodes. - (make-essential-device-nodes #:root "/rw-root") - - ;; Make /root a union of the tmpfs and the actual root. - (unless (zero? (system* unionfs "-o" - "cow,allow_other,use_ino,suid,dev" - "/rw-root=RW:/real-root=RO" - "/root")) - (error "unionfs failed"))) - (mount root "/root" "ext3"))) - (lambda args - (format (current-error-port) "exception while mounting '~a': ~s~%" - root args) - (start-repl))) + (mount-root-file-system root root-fs-type + #:volatile-root? volatile-root? + #:unionfs unionfs) (mount "none" "/root" "tmpfs")) (mount-essential-file-systems #:root "/root") @@ -308,16 +318,7 @@ to it are lost." (make-essential-device-nodes #:root "/root")) ;; Mount the specified file systems. - (for-each (match-lambda - (('cifs source target) - (let ((target (string-append "/root/" target))) - (mkdir-p target) - (mount-qemu-smb-share source target))) - (('9p source target) - (let ((target (string-append "/root/" target))) - (mkdir-p target) - (mount-qemu-9p source target)))) - mounts) + (for-each mount-file-system mounts) (when guile-modules-in-chroot? ;; Copy the directories that contain .scm and .go files so that the -- cgit v1.2.3 From 3c986b75f5705b37833d15353aad9a8db6d7b65b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 00:43:37 +0200 Subject: ftp-client: Add missing CR in "USER" command. * guix/ftp-client.scm (%ftp-login): Add #\return before #\newline. Fixes access to some FTP servers, such as ftp://invisible-island.net ("ProFTPD 1.3.4a Server"). --- guix/ftp-client.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index dd9135e95a..761980ac8f 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -73,7 +73,8 @@ (throw 'ftp-error port command code message)))) (define (%ftp-login user pass port) - (let ((command (string-append "USER " user (string #\newline)))) + (let ((command (string-append "USER " user + (string #\return) (string #\newline)))) (display command port) (let-values (((code message) (%ftp-listen port))) (case code -- cgit v1.2.3 From 83a39ed7dbb975e20098c7034f9e6daba7dd02bf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 00:46:34 +0200 Subject: gnu: Add diffstat. * gnu/packages/version-control.scm (diffstat): New variable. --- gnu/packages/version-control.scm | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm index f63df4a2ff..ed7d6f61ad 100644 --- a/gnu/packages/version-control.scm +++ b/gnu/packages/version-control.scm @@ -21,7 +21,8 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu packages version-control) - #:use-module ((guix licenses) #:select (asl2.0 gpl1+ gpl2 gpl2+ gpl3+)) + #:use-module ((guix licenses) + #:select (asl2.0 gpl1+ gpl2 gpl2+ gpl3+ x11-style)) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) @@ -413,3 +414,24 @@ when a file change has been described in the ChangeLog but the file has not been added to the VC. vc-chlog scans changed files and generates standards-compliant ChangeLog entries based on the changes that it detects.") (license gpl3+))) + +(define-public diffstat + (package + (name "diffstat") + (version "1.58") + (source (origin + (method url-fetch) + (uri (string-append + "ftp://invisible-island.net/diffstat/diffstat-" + version ".tgz")) + (sha256 + (base32 + "14rpf5c05ff30f6vn6pn6pzy0k4g4is5im656ahsxff3k58i7mgs")))) + (build-system gnu-build-system) + (home-page "http://invisible-island.net/diffstat/") + (synopsis "Make histograms from the output of 'diff'") + (description + "diffstat reads the output of 'diff' and displays a histogram of the +insertions, deletions, and modifications per-file. It is useful for reviewing +large, complex patch files.") + (license (x11-style "file://COPYING")))) -- cgit v1.2.3 From e20fd1bf80d8038b56abe29d6bf0f1d7150fddd5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 12:02:43 +0200 Subject: doc: Minor improvements in "G-Expressions". * doc/guix.texi (G-Expressions): Show coreutils version number in store file name. Add xref to "Derivations", in documentation of 'gexp->derivation'. Fix typo. --- doc/guix.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 99acad56e7..e127b0f76a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2050,7 +2050,7 @@ derivation that builds a directory containing exactly one symlink to (gexp->derivation "the-thing" build-exp) @end example -As one would expect, the @code{"/gnu/store/@dots{}-coreutils"} string is +As one would expect, the @code{"/gnu/store/@dots{}-coreutils-8.22"} string is substituted to the reference to the @var{coreutils} package in the actual build code, and @var{coreutils} is automatically made an input to the derivation. Likewise, @code{#$output} (equivalent to @code{(ungexp @@ -2127,7 +2127,7 @@ search path to be copied in the store, compiled, and made available in the load path during the execution of @var{exp}---e.g., @code{((guix build utils) (guix build gnu-build-system))}. -The other arguments are as for @code{derivation}. +The other arguments are as for @code{derivation} (@pxref{Derivations}). @end deffn @deffn {Monadic Procedure} gexp->script @var{name} @var{exp} @@ -2146,7 +2146,7 @@ command: @end example When ``running'' it through the store (@pxref{The Store Monad, -@code{run-with-store}}), we obtain a derivation that procedures an +@code{run-with-store}}), we obtain a derivation that produces an executable file @file{/gnu/store/@dots{}-list-files} along these lines: @example -- cgit v1.2.3 From 03ddfaf5fb5fab78f7180089158bea0494072b3c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 12:16:10 +0200 Subject: vm: Make root file system type a parameter, and default to ext4. * gnu/system/vm.scm (qemu-image): Add #:file-system-type parameter. Pass it to 'initialize-hard-disk'. * guix/build/linux-initrd.scm (mount-root-file-system): Always honor TYPE. (boot-system): Change #:root-fs-type to default to "ext4". Update docstring. * guix/build/vm.scm (initialize-hard-disk): Remove #:mkfs parameter; add #:file-system-type. Adjust 'mkfs' invocation and 'mount' call to honor #:file-system-type. --- gnu/system/vm.scm | 11 +++++++---- guix/build/linux-initrd.scm | 7 +++++-- guix/build/vm.scm | 9 +++++---- 3 files changed, 17 insertions(+), 10 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index c080317415..867e01ad5f 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -188,13 +188,15 @@ made available under the /xchg CIFS share." (system (%current-system)) (qemu qemu-headless) (disk-image-size (* 100 (expt 2 20))) + (file-system-type "ext4") grub-configuration (initialize-store? #f) (populate #f) (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 (GRUB-CONFIGURATION must be the name of a file in the VM.) + "Return a bootable, stand-alone QEMU image, with a root partition of type +FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB +installation that uses GRUB-CONFIGURATION as its configuration +file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied into the image being built. When INITIALIZE-STORE? is true, initialize the @@ -235,6 +237,7 @@ such as /etc files." (initialize-hard-disk #:grub.cfg #$grub-configuration #:closures-to-copy graphs #:disk-image-size #$disk-image-size + #:file-system-type #$file-system-type #:initialize-store? #$initialize-store? #:directives '#$populate) (reboot)))) @@ -315,7 +318,7 @@ environment with the store shared with the host." (file-systems (list (file-system (mount-point "/") (device "/dev/vda1") - (type "ext3")) + (type "ext4")) (file-system (mount-point (%store-prefix)) (device "store") diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 1e0d6e27ec..fd6c0c4673 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -212,7 +212,7 @@ UNIONFS." "/rw-root=RW:/real-root=RO" "/root")) (error "unionfs failed"))) - (mount root "/root" "ext3"))) + (mount root "/root" type))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) @@ -249,7 +249,7 @@ FLAGS must be a list of symbols." qemu-guest-networking? guile-modules-in-chroot? volatile-root? unionfs - (root-fs-type "ext3") + (root-fs-type "ext4") (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -257,6 +257,9 @@ 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'. +Mount the root file system, of type ROOT-FS-TYPE, 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 diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 33c898d968..1d1abad1dd 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -183,7 +183,7 @@ as created and modified at the Epoch." (define* (initialize-hard-disk #:key grub.cfg disk-image-size - (mkfs "mkfs.ext3") + (file-system-type "ext4") initialize-store? (closures-to-copy '()) (directives '())) @@ -192,13 +192,14 @@ as created and modified at the Epoch." (- disk-image-size (* 5 (expt 2 20)))) (error "failed to create partition table")) - (display "creating ext3 partition...\n") - (unless (zero? (system* mkfs "-F" "/dev/sda1")) + (format #t "creating ~a partition...\n" file-system-type) + (unless (zero? (system* (string-append "mkfs." file-system-type) + "-F" "/dev/sda1")) (error "failed to create partition")) (display "mounting partition...\n") (mkdir "/fs") - (mount "/dev/sda1" "/fs" "ext3") + (mount "/dev/sda1" "/fs" file-system-type) (when (pair? closures-to-copy) ;; Populate the store. -- cgit v1.2.3 From 66f23d66219533aff689a05d16439827da1a2a59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 12:45:43 +0200 Subject: vm: Provide a root partition for the freestanding VM image. Fixes a regression introduced in 83bcd0b. * gnu/system/vm.scm (system-qemu-image): Override the 'file-systems' field of OS. Add #:file-system-type parameter and honor it. --- gnu/system/vm.scm | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 867e01ad5f..786e564031 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -296,19 +296,28 @@ basic contents of the root file system of OS." (operating-system-users os)))))) (define* (system-qemu-image os - #:key (disk-image-size (* 900 (expt 2 20)))) - "Return the derivation of a QEMU image of DISK-IMAGE-SIZE bytes of the GNU -system as described by OS." - (mlet* %store-monad - ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) - (qemu-image #:grub-configuration grub.cfg - #:populate populate - #:disk-image-size disk-image-size - #:initialize-store? #t - #:inputs-to-copy `(("system" ,os-drv))))) + #:key + (file-system-type "ext4") + (disk-image-size (* 900 (expt 2 20)))) + "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes +of the GNU system as described by OS." + (let ((os (operating-system (inherit os) + ;; The mounted file systems are under our control. + (file-systems (list (file-system + (mount-point "/") + (device "/dev/sda1") + (type file-system-type))))))) + (mlet* %store-monad + ((os-drv (operating-system-derivation os)) + (os-dir -> (derivation->output-path os-drv)) + (grub.cfg -> (string-append os-dir "/grub.cfg")) + (populate (operating-system-default-contents os))) + (qemu-image #:grub-configuration grub.cfg + #:populate populate + #:disk-image-size disk-image-size + #:file-system-type file-system-type + #:initialize-store? #t + #:inputs-to-copy `(("system" ,os-drv)))))) (define (virtualized-operating-system os) "Return an operating system based on OS suitable for use in a virtualized -- cgit v1.2.3 From e102f940976ad3703981e7f7bf5455843054d687 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 May 2014 16:37:04 +0200 Subject: gnu: Add statically-linked versions of e2fsprogs and the fsck.* commands. * gnu/packages/linux.scm (e2fsprogs/static, e2fsck/static): New variables. --- gnu/packages/linux.scm | 45 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index 759b92d51e..3325679258 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -42,7 +42,8 @@ #:use-module (guix download) #:use-module (guix build-system gnu) #:use-module (guix build-system cmake) - #:use-module (guix build-system python)) + #:use-module (guix build-system python) + #:use-module (guix build-system trivial)) (define-public (system->linux-architecture arch) "Return the Linux architecture name for ARCH, a Guix system name such as @@ -466,6 +467,48 @@ slabtop, and skill.") lgpl2.0 ; libext2fs x11)))) ; libuuid +(define-public e2fsprogs/static + (package (inherit e2fsprogs) + (name "e2fsprogs-static") + (arguments + `(#:configure-flags '("LDFLAGS=-static") + ,@(package-arguments e2fsprogs))) + (synopsis + "Statically-linked version of the ext2/ext3/ext4 file system tools"))) + +(define-public e2fsck/static + (package + (name "e2fsck-static") + (version (package-version e2fsprogs/static)) + (build-system trivial-build-system) + (source #f) + (arguments + `(#:modules ((guix build utils)) + #:builder + (begin + (use-modules (guix build utils) + (ice-9 ftw) + (srfi srfi-26)) + + (let ((source (string-append (assoc-ref %build-inputs "e2fsprogs") + "/sbin")) + (bin (string-append (assoc-ref %outputs "out") "/sbin"))) + (mkdir-p bin) + (with-directory-excursion bin + (for-each (lambda (file) + (copy-file (string-append source "/" file) + file) + (remove-store-references file) + (chmod file #o555)) + (scandir source (cut string-prefix? "fsck." <>)))))))) + (inputs `(("e2fsprogs" ,e2fsprogs/static))) + (synopsis "Statically-linked fsck.* commands from e2fsprogs") + (description + "This package provides statically-linked command of fsck.ext[234] taken +from the e2fsprogs package. It is meant to be used in initrds.") + (home-page (package-home-page e2fsprogs/static)) + (license (package-license e2fsprogs/static)))) + (define-public strace (package (name "strace") -- cgit v1.2.3 From ad896f23a5fac38294e7515587c0c5bda02e9a59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 00:18:46 +0200 Subject: activation: Fix deletion of setuid programs. * guix/build/activation.scm (activate-setuid-programs): When %SETUID-DIRECTORY exists, pass the right file names to 'delete-file'. --- guix/build/activation.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 6930a8c585..f9d9ba5cbd 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -19,6 +19,7 @@ (define-module (guix build activation) #:use-module (guix build utils) #:use-module (ice-9 ftw) + #:use-module (srfi srfi-26) #:export (activate-etc activate-setuid-programs)) @@ -85,7 +86,8 @@ (format #t "setting up setuid programs in '~a'...~%" %setuid-directory) (if (file-exists? %setuid-directory) - (for-each delete-file + (for-each (compose delete-file + (cut string-append %setuid-directory "/" <>)) (scandir %setuid-directory (lambda (file) (not (member file '("." "..")))) -- cgit v1.2.3 From 3c05b4bc2528ea64b259477bf58dbcc6a7739f78 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 00:30:39 +0200 Subject: linux-initrd: Check the root and other early file systems. * gnu/system.scm (operating-system-derivation)[boot-file-systems]: Keep "/". * gnu/system/linux-initrd.scm (file-system->spec): Keep the 'check?' flag. (qemu-initrd)[helper-packages]: New variable. Pass it as #:to-copy. : Add 'set-path-environment-variable' call. Remove #:unionfs argument for 'boot-system'. * gnu/system/vm.scm (%linux-vm-file-systems): Add 'check?' field/ (virtualized-operating-system): Likewise for the "9p" file system. * guix/build/linux-initrd.scm (mount-root-file-system): Change #:unionfs default. Call 'check-file-system' before mounting ROOT, when VOLATILE-ROOT? is false. (check-file-system): New procedure. (mount-file-system): Honor 'check?' element in list; add 'check-file-system' call. (boot-system): Remove #:root-fs-type and #:unionfs parameters. [root-mount-point?, root-fs-type]: New variables. Call 'mount-file-system' on all MOUNTS but "/". --- gnu/system.scm | 6 +++-- gnu/system/linux-initrd.scm | 27 +++++++++++++++----- gnu/system/vm.scm | 9 ++++--- guix/build/linux-initrd.scm | 62 ++++++++++++++++++++++++++++++++++++--------- 4 files changed, 80 insertions(+), 24 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index 7624b10ae4..65d1ca3418 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -349,8 +349,10 @@ we're running in the final root." "Return a derivation that builds OS." (define boot-file-systems (filter (match-lambda - (($ device mount-point type _ _ boot?) - (and boot? (not (string=? mount-point "/"))))) + (($ device "/") + #t) + (($ device mount-point type flags options boot?) + boot?)) (operating-system-file-systems os))) (mlet* %store-monad diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 8b4ab9c4eb..749dfa313f 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -198,8 +198,8 @@ a list of Guile module names to be embedded in the initrd." "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ device mount-point type flags options) - (list device mount-point type flags options)))) + (($ device mount-point type flags options _ check?) + (list device mount-point type flags options check?)))) (define* (qemu-initrd file-systems #:key @@ -243,24 +243,37 @@ exception and backtrace!)." '("fuse.ko") '()))) + (define helper-packages + ;; Packages to be copied on the initrd. + `(,@(if (find (lambda (fs) + (string-prefix? "ext" (file-system-type fs))) + file-systems) + (list e2fsck/static) + '()) + ,@(if volatile-root? + (list unionfs-fuse/static) + '()))) + (expression->initrd #~(begin (use-modules (guix build linux-initrd) + (guix build utils) (srfi srfi-26)) + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages))) + (boot-system #:mounts '#$(map file-system->spec file-systems) #:linux-modules '#$linux-modules #:qemu-guest-networking? #t #:guile-modules-in-chroot? '#$guile-modules-in-chroot? - #:unionfs (and=> #$(and volatile-root? unionfs-fuse/static) - (cut string-append <> "/bin/unionfs")) #:volatile-root? '#$volatile-root?)) #:name "qemu-initrd" #:modules '((guix build utils) (guix build linux-initrd)) - #:to-copy (if volatile-root? - (list unionfs-fuse/static) - '()) + #:to-copy helper-packages #:linux linux-libre #:linux-modules linux-modules)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 786e564031..b20831f44d 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -90,13 +90,15 @@ input tuple. The output file name is when building for SYSTEM." (device "store") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")) + (options "trans=virtio") + (check? #f)) (file-system (mount-point "/xchg") (device "xchg") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")))) + (options "trans=virtio") + (check? #f)))) (define* (expression->derivation-in-linux-vm name exp #:key @@ -333,7 +335,8 @@ environment with the store shared with the host." (device "store") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")))))) + (options "trans=virtio") + (check? #f)))))) (define* (system-qemu-image/shared-store os diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index fd6c0c4673..b2cbcae7d8 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -190,7 +190,7 @@ the last argument of `mknod'." (+ (* major 256) minor)) (define* (mount-root-file-system root type - #:key volatile-root? unionfs) + #:key volatile-root? (unionfs "unionfs")) "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is true, mount ROOT read-only and make it a union with a writable tmpfs using UNIONFS." @@ -212,20 +212,45 @@ UNIONFS." "/rw-root=RW:/real-root=RO" "/root")) (error "unionfs failed"))) - (mount root "/root" type))) + (begin + (check-file-system root type) + (mount root "/root" type)))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) (start-repl)))) +(define (check-file-system device type) + "Run a file system check of TYPE on DEVICE." + (define fsck + (string-append "fsck." type)) + + (let ((status (system* fsck "-v" "-p" device))) + (match (status:exit-val status) + (0 + #t) + (1 + (format (current-error-port) "'~a' corrected errors on ~a; continuing~%" + fsck device)) + (2 + (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%" + fsck device) + (sleep 3) + (reboot)) + (code + (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%" + fsck code device) + (start-repl))))) + (define* (mount-file-system spec #:key (root "/root")) "Mount the file system described by SPEC under ROOT. SPEC must have the form: - (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS) + (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; -FLAGS must be a list of symbols." +FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to +run a file system check." (define flags->bit-mask (match-lambda (('read-only rest ...) @@ -236,8 +261,10 @@ FLAGS must be a list of symbols." 0))) (match spec - ((source mount-point type (flags ...) options) + ((source mount-point type (flags ...) options check?) (let ((mount-point (string-append root "/" mount-point))) + (when check? + (check-file-system source type)) (mkdir-p mount-point) (mount source mount-point type (flags->bit-mask flags) (if options @@ -248,8 +275,7 @@ FLAGS must be a list of symbols." (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? - volatile-root? unionfs - (root-fs-type "ext4") + volatile-root? (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -257,8 +283,8 @@ 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'. -Mount the root file system, of type ROOT-FS-TYPE, specified by the '--root' -command-line argument, if any. +Mount the root file system, specified by the '--root' command-line argument, +if any. MOUNTS must be a list suitable for 'mount-file-system'. @@ -276,6 +302,18 @@ to it are lost." (resolve (string-append "/root" target))) file))) + (define root-mount-point? + (match-lambda + ((device "/" _ ...) #t) + (_ #f))) + + (define root-fs-type + (or (any (match-lambda + ((device "/" type _ ...) type) + (_ #f)) + mounts) + "ext4")) + (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") @@ -310,8 +348,7 @@ to it are lost." (mkdir "/root")) (if root (mount-root-file-system root root-fs-type - #:volatile-root? volatile-root? - #:unionfs unionfs) + #:volatile-root? volatile-root?) (mount "none" "/root" "tmpfs")) (mount-essential-file-systems #:root "/root") @@ -321,7 +358,8 @@ to it are lost." (make-essential-device-nodes #:root "/root")) ;; Mount the specified file systems. - (for-each mount-file-system mounts) + (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 -- cgit v1.2.3 From 0e2672aee3087e31bb49920c3eb1544220ae33d4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 11:15:30 +0200 Subject: gnu: Add missing import in (gnu packages maths). * gnu/packages/maths.scm: Use (guix utils), which was needed since b9100e2f. --- gnu/packages/maths.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 93ae0bd3ba..2018e1706f 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -25,6 +25,7 @@ #:renamer (symbol-prefix-proc 'license:)) #:use-module (guix packages) #:use-module (guix download) + #:use-module (guix utils) #:use-module (guix build-system cmake) #:use-module (guix build-system gnu) #:use-module (gnu packages algebra) -- cgit v1.2.3 From 2d49f8452215ab6e898589cd757d02fc1f1fc930 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 21:09:29 +0200 Subject: services: networking: Fix typo in static networking service. * gnu/services/networking.scm (static-networking-service): Use $inetutils/bin/ifconfig, not $inetutils/sbin/ifconfig. --- gnu/services/networking.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 5522541735..8bb05850e3 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -73,7 +73,7 @@ true, it must be a string specifying the default network gateway." #t)))) (stop #~(lambda _ ;; Return #f is successfully stopped. - (not (and (system* (string-append #$inetutils "/sbin/ifconfig") + (not (and (system* (string-append #$inetutils "/bin/ifconfig") #$interface "down") (system* (string-append #$net-tools "/sbin/route") "del" "-net" "default"))))) -- cgit v1.2.3 From 1d4628329d37c5e5857c70f3720b941e4bbcfcd2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 May 2014 22:24:47 +0200 Subject: linux-initrd: Improve root file system switching. * guix/build/linux-initrd.scm (move-essential-file-systems, switch-root): New procedures. (MS_MOVE): New variable. (boot-system): Remove 'mount-essential-file-systems' call for ROOT. Use 'switch-root' instead of chdir + chroot. --- guix/build/linux-initrd.scm | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b2cbcae7d8..b133550bca 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -62,6 +62,15 @@ (mkdir (scope "sys"))) (mount "none" (scope "sys") "sysfs")) +(define (move-essential-file-systems root) + "Move currently mounted essential file systems to ROOT." + (for-each (lambda (dir) + (let ((target (string-append root dir))) + (unless (file-exists? target) + (mkdir target)) + (mount dir target "" MS_MOVE))) + '("/proc" "/sys"))) + (define (linux-command-line) "Return the Linux kernel command line as a list of strings." (string-tokenize @@ -172,6 +181,7 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." ;; Linux mount flags, from libc's . (define MS_RDONLY 1) (define MS_BIND 4096) +(define MS_MOVE 8192) (define (bind-mount source target) "Bind-mount SOURCE at TARGET." @@ -271,6 +281,15 @@ run a file system check." (string->pointer options) %null-pointer)))))) +(define (switch-root root) + "Switch to ROOT as the root file system, in a way similar to what +util-linux' switch_root(8) does." + (move-essential-file-systems root) + (chdir root) + ;; TODO: Delete files from the old root. + (mount root "/" "" MS_MOVE) + (chroot ".")) + (define* (boot-system #:key (linux-modules '()) qemu-guest-networking? @@ -351,8 +370,6 @@ to it are lost." #:volatile-root? volatile-root?) (mount "none" "/root" "tmpfs")) - (mount-essential-file-systems #:root "/root") - (unless (file-exists? "/root/dev") (mkdir "/root/dev") (make-essential-device-nodes #:root "/root")) @@ -377,8 +394,7 @@ to it are lost." (if to-load (begin (format #t "loading '~a'...\n" to-load) - (chdir "/root") - (chroot "/root") + (switch-root "/root") ;; Obviously this has to be done each time we boot. Do it from here ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) -- cgit v1.2.3 From 515eba4543f658799b1e11d187fa599d0a9a0dce Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 May 2014 09:00:00 +0200 Subject: gnu-maintenance: Add missing type check. * guix/gnu-maintenance.scm (gnu-package?): Only call 'mirror-type' when URL is a string. --- guix/gnu-maintenance.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index d8b6af9d31..7b608daea2 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -176,7 +176,7 @@ network to check in GNU's database." (let ((url (and=> (package-source package) origin-uri)) (name (package-name package))) - (case (and url (mirror-type url)) + (case (and (string? url) (mirror-type url)) ((gnu) #t) ((non-gnu) #f) (else -- cgit v1.2.3 From 6f194a1e7700997d3c61fa91c58c36da0f96e5c2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 May 2014 17:12:55 +0200 Subject: gnu: pybugz: Add fixlet patches. * gnu/packages/python.scm (python2-pybugz)[source]: Add 'patches' field. * gnu/packages/patches/pybugz-encode-error.patch, gnu/packages/patches/pybugz-stty.patch: New files. * gnu-system.am (dist_patch_DATA): Add them. --- gnu-system.am | 2 ++ gnu/packages/patches/pybugz-encode-error.patch | 17 +++++++++++++++++ gnu/packages/patches/pybugz-stty.patch | 19 +++++++++++++++++++ gnu/packages/python.scm | 5 ++++- 4 files changed, 42 insertions(+), 1 deletion(-) create mode 100644 gnu/packages/patches/pybugz-encode-error.patch create mode 100644 gnu/packages/patches/pybugz-stty.patch diff --git a/gnu-system.am b/gnu-system.am index 0bf3eece30..5ebcf67d5c 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -326,6 +326,8 @@ dist_patch_DATA = \ gnu/packages/patches/petsc-fix-threadcomm.patch \ gnu/packages/patches/plotutils-libpng-jmpbuf.patch \ gnu/packages/patches/procps-make-3.82.patch \ + gnu/packages/patches/pybugz-encode-error.patch \ + gnu/packages/patches/pybugz-stty.patch \ gnu/packages/patches/python-fix-tests.patch \ gnu/packages/patches/python-libffi-mips-n32-fix.patch \ gnu/packages/patches/qt4-tests.patch \ diff --git a/gnu/packages/patches/pybugz-encode-error.patch b/gnu/packages/patches/pybugz-encode-error.patch new file mode 100644 index 0000000000..ab78bf84b3 --- /dev/null +++ b/gnu/packages/patches/pybugz-encode-error.patch @@ -0,0 +1,17 @@ +In case of 'AttributeError', 'value' is None, so do not try to +access it. +Submitted upstream. + +--- pybugz-0.6.11/bugz.py 2006-09-02 14:35:37.000000000 +0200 ++++ pybugz-0.6.11/bugz.py 2014-05-05 16:02:20.000000000 +0200 +@@ -1249,9 +1254,9 @@ class PrettyBugz(Bugz): + for field, name in FIELDS + MORE_FIELDS: + try: + value = result.find('//%s' % field).text ++ print '%-12s: %s' % (name, value.encode(self.enc)) + except AttributeError: + continue +- print '%-12s: %s' % (name, value.encode(self.enc)) + + # Print out the cc'ed people + cced = result.findall('.//cc') diff --git a/gnu/packages/patches/pybugz-stty.patch b/gnu/packages/patches/pybugz-stty.patch new file mode 100644 index 0000000000..4453e9d027 --- /dev/null +++ b/gnu/packages/patches/pybugz-stty.patch @@ -0,0 +1,19 @@ +Gracefully deal with 'stty size' failures. +Submitted upstream. + +--- pybugz-0.6.11/bugz.py 2006-09-02 14:35:37.000000000 +0200 ++++ pybugz-0.6.11/bugz.py 2014-05-05 15:17:03.000000000 +0200 +@@ -288,7 +288,12 @@ def get_cols(): + stty = which('stty') + if stty: + row_cols = commands.getoutput("%s size" % stty) +- rows, cols = map(int, row_cols.split()) ++ try: ++ rows, cols = map(int, row_cols.split()) ++ except: ++ # In some cases 'stty size' will just fail with ++ # "Inappropriate ioctl for device". ++ cols = DEFAULT_NUM_COLS + return cols + else: + return DEFAULT_NUM_COLS diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 372f763ee5..d3d4f390ff 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -578,7 +578,10 @@ commands.") version ".tar.gz")) (sha256 (base32 - "17ni00p08gp5lkxlrrcnvi3x09fmajnlbz4da03qcgl9q21ym4jd")))) + "17ni00p08gp5lkxlrrcnvi3x09fmajnlbz4da03qcgl9q21ym4jd")) + (patches (map search-patch + (list "pybugz-stty.patch" + "pybugz-encode-error.patch"))))) (build-system python-build-system) (arguments `(#:python ,python-2 ; SyntaxError with Python 3 -- cgit v1.2.3 From 1dd26275a35f987e1083d428fe30b3501acae94f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 00:07:36 +0200 Subject: gnu: Add libcroco. * gnu/packages/gnome.scm (libcroco): New variable. --- gnu/packages/gnome.scm | 64 ++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 49 insertions(+), 15 deletions(-) diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 5d17b019fd..483c3d085b 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +18,8 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu packages gnome) - #:use-module ((guix licenses) #:select (gpl2 gpl2+ lgpl2.0+ lgpl2.1+ lgpl3)) + #:use-module ((guix licenses) + #:renamer (symbol-prefix-proc 'license:)) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) @@ -36,6 +38,7 @@ #:use-module (gnu packages python) #:use-module (gnu packages xml) #:use-module (gnu packages gl) + #:use-module (gnu packages compression) #:use-module (gnu packages xorg)) (define-public brasero @@ -75,7 +78,7 @@ (description "Brasero is an application to burn CD/DVD for the Gnome Desktop. It is designed to be as simple as possible and has some unique features to enable users to create their discs easily and quickly.") - (license gpl2+))) + (license license:gpl2+))) (define-public gnome-desktop (package @@ -116,7 +119,7 @@ stability. Documentation for the API is available with gtk-doc. The gnome-about program helps find which version of GNOME is installed.") ; Some bits under the LGPL. - (license gpl2+))) + (license license:gpl2+))) (define-public gnome-doc-utils (package @@ -146,7 +149,7 @@ The gnome-about program helps find which version of GNOME is installed.") "Gnome-doc-utils is a collection of documentation utilities for the Gnome project. It includes xml2po tool which makes it easier to translate and keep up to date translations of documentation.") - (license gpl2+))) ; xslt under lgpl + (license license:gpl2+))) ; xslt under lgpl (define-public libgnome-keyring (package @@ -177,7 +180,7 @@ and keep up to date translations of documentation.") "Client library to access passwords from the GNOME keyring.") ;; Though a couple of files are LGPLv2.1+. - (license lgpl2.0+))) + (license license:lgpl2.0+))) (define-public evince (package @@ -242,7 +245,7 @@ and keep up to date translations of documentation.") currently supports PDF, PostScript, DjVu, TIFF and DVI. The goal of Evince is to replace the multiple document viewers that exist on the GNOME Desktop with a single simple application.") - (license gpl2+))) + (license license:gpl2+))) (define-public gsettings-desktop-schemas (package @@ -269,7 +272,7 @@ on the GNOME Desktop with a single simple application.") (description "Gsettings-desktop-schemas contains a collection of GSettings schemas for settings shared by various components of the GNOME desktop.") - (license lgpl2.1+))) + (license license:lgpl2.1+))) (define-public icon-naming-utils (package @@ -294,7 +297,7 @@ for settings shared by various components of the GNOME desktop.") "To help with the transition to the Freedesktop Icon Naming Specification, the icon naming utility maps the icon names used by the GNOME and KDE desktops to the icon names proposed in the specification.") - (license lgpl2.1+))) + (license license:lgpl2.1+))) (define-public gnome-icon-theme (package @@ -321,7 +324,7 @@ GNOME and KDE desktops to the icon names proposed in the specification.") "GNOME icon theme") (description "Icons for the GNOME desktop.") - (license lgpl3))) ; or Creative Commons BY-SA 3.0 + (license license:lgpl3))) ; or Creative Commons BY-SA 3.0 (define-public shared-mime-info (package @@ -352,7 +355,7 @@ and the update-mime-database command used to extend it. It requires glib2 to be installed for building the update command. Additionally, it uses intltool for translations, though this is only a dependency for the maintainers. This database is translated at Transifex.") - (license gpl2+))) + (license license:gpl2+))) (define-public hicolor-icon-theme (package @@ -374,7 +377,7 @@ database is translated at Transifex.") "Freedesktop icon theme") (description "Freedesktop icon theme.") - (license gpl2))) + (license license:gpl2))) (define-public libnotify (package @@ -405,7 +408,7 @@ database is translated at Transifex.") notification daemon, as defined in the Desktop Notifications spec. These notifications can be used to inform the user about an event or display some form of information without getting in the user's way.") - (license lgpl2.1+))) + (license license:lgpl2.1+))) (define-public libpeas (package @@ -469,7 +472,7 @@ set of features including, but not limited to: multiple extension points; on demand (lazy) programming language support for C, Python and JS; simplicity of the API") - (license lgpl2.0+))) + (license license:lgpl2.0+))) (define-public gtkglext (package @@ -495,7 +498,7 @@ the API") (description "GtkGLExt is an OpenGL extension to GTK+. It provides additional GDK objects which support OpenGL rendering in GTK+ and GtkWidget API add-ons to make GTK+ widgets OpenGL-capable.") - (license lgpl2.1+))) + (license license:lgpl2.1+))) (define-public glade3 (package @@ -522,4 +525,35 @@ API add-ons to make GTK+ widgets OpenGL-capable.") (description "Glade is a rapid application development (RAD) tool to enable quick & easy development of user interfaces for the GTK+ toolkit and the GNOME desktop environment.") - (license lgpl2.0+))) + (license license:lgpl2.0+))) + +(define-public libcroco + (package + (name "libcroco") + (version "0.6.8") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/libcroco/0.6/libcroco-" + version + ".tar.xz")) + (sha256 + (base32 + "0w453f3nnkbkrly7spx5lx5pf6mwynzmd5qhszprq8amij2invpa")))) + (build-system gnu-build-system) + (native-inputs + `(("pkg-config" ,pkg-config))) + (inputs + `(("glib" ,glib) + ("libxml2" ,libxml2) + ("zlib" ,zlib))) + (home-page "https://github.com/GNOME/libcroco") + (synopsis "CSS2 parsing and manipulation library") + (description + "Libcroco is a standalone CSS2 parsing and manipulation library. +The parser provides a low level event driven SAC-like API and a CSS object +model like API. Libcroco provides a CSS2 selection engine and an experimental +XML/CSS rendering engine.") + + ;; LGPLv2.1-only. + (license license:lgpl2.1))) -- cgit v1.2.3 From 251785941159fe57d28558381ab580433fc78099 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 00:26:10 +0200 Subject: gnu: Add libgsf. * gnu/packages/gnome.scm (libgsf): New variable. --- gnu/packages/gnome.scm | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 483c3d085b..221c16ca57 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -557,3 +557,35 @@ XML/CSS rendering engine.") ;; LGPLv2.1-only. (license license:lgpl2.1))) + +(define-public libgsf + (package + (name "libgsf") + (version "1.14.30") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnome/sources/libgsf/1.14/libgsf-" + version ".tar.xz")) + (sha256 + (base32 + "0w2v1a9sxsymd1mcy4mwsz4r6za9iwq69rj86nb939p41d4c6j6b")))) + (build-system gnu-build-system) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (inputs + `(("python" ,python) + ("zlib" ,zlib) + ("bzip2" ,bzip2))) + (propagated-inputs + `(("gdk-pixbuf" ,gdk-pixbuf) + ("glib" ,glib) + ("libxml2" ,libxml2))) + (home-page "http://www.gnome.org/projects/libgsf") + (synopsis "GNOME's Structured File Library") + (description + "Libgsf aims to provide an efficient extensible I/O abstraction for +dealing with different structured file formats.") + + ;; LGPLv2.1-only. + (license license:lgpl2.1))) -- cgit v1.2.3 From 03f4500118eb89a36d6c4978a993c0424b7d8aa4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 14:06:16 +0200 Subject: gnu: gdb: Add dependency on libxml2. * gnu/packages/gdb.scm (gdb)[inputs]: Add LIBXML2. --- gnu/packages/gdb.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/gnu/packages/gdb.scm b/gnu/packages/gdb.scm index f521ef5839..a786383027 100644 --- a/gnu/packages/gdb.scm +++ b/gnu/packages/gdb.scm @@ -57,7 +57,11 @@ ("readline" ,readline) ("ncurses" ,ncurses) ("python" ,python-wrapper) - ("dejagnu" ,dejagnu))) + ("dejagnu" ,dejagnu) + + ;; Allow use of XML-formatted syscall information. This enables 'catch + ;; syscall' and similar commands. + ("libxml2" ,libxml2))) (native-inputs `(("texinfo" ,texinfo))) (home-page "http://www.gnu.org/software/gdb/") -- cgit v1.2.3 From fd42e6b80343f0a250396150d00c0d3401ac60a9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 14:06:41 +0200 Subject: gnu: gdb: Upgrade to 7.7.1. * gnu/packages/gdb.scm (gdb): Upgrade to 7.7.1. --- gnu/packages/gdb.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/gdb.scm b/gnu/packages/gdb.scm index a786383027..1b8a0bbe22 100644 --- a/gnu/packages/gdb.scm +++ b/gnu/packages/gdb.scm @@ -33,14 +33,14 @@ (define-public gdb (package (name "gdb") - (version "7.7") + (version "7.7.1") (source (origin (method url-fetch) (uri (string-append "mirror://gnu/gdb/gdb-" version ".tar.bz2")) (sha256 (base32 - "08vcb97j1b7vxwq6088wb6s3g3bm8iwikd922y0xsgbbxv3d2104")))) + "199sn1p0gzli6icp9dcvrphdvyi7hm4cc9zhziq0q6vg81h55g8d")))) (build-system gnu-build-system) (arguments '(#:tests? #f ; FIXME "make check" fails on single-processor systems. -- cgit v1.2.3 From 0997771ac19d7aa5c51ba25f87f9e08de324edae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 14:12:41 +0200 Subject: gnu: e2fsprogs: Use 'static-package' for the statically-linked variant. * gnu/packages/linux.scm (e2fsprogs/static): Remove. (e2fsck/static): Use (static-package e2fsprogs) instead. --- gnu/packages/linux.scm | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index 3325679258..f04fd5ce6b 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -467,19 +467,10 @@ slabtop, and skill.") lgpl2.0 ; libext2fs x11)))) ; libuuid -(define-public e2fsprogs/static - (package (inherit e2fsprogs) - (name "e2fsprogs-static") - (arguments - `(#:configure-flags '("LDFLAGS=-static") - ,@(package-arguments e2fsprogs))) - (synopsis - "Statically-linked version of the ext2/ext3/ext4 file system tools"))) - (define-public e2fsck/static (package (name "e2fsck-static") - (version (package-version e2fsprogs/static)) + (version (package-version e2fsprogs)) (build-system trivial-build-system) (source #f) (arguments @@ -501,13 +492,13 @@ slabtop, and skill.") (remove-store-references file) (chmod file #o555)) (scandir source (cut string-prefix? "fsck." <>)))))))) - (inputs `(("e2fsprogs" ,e2fsprogs/static))) + (inputs `(("e2fsprogs" ,(static-package e2fsprogs)))) (synopsis "Statically-linked fsck.* commands from e2fsprogs") (description "This package provides statically-linked command of fsck.ext[234] taken from the e2fsprogs package. It is meant to be used in initrds.") - (home-page (package-home-page e2fsprogs/static)) - (license (package-license e2fsprogs/static)))) + (home-page (package-home-page e2fsprogs)) + (license (package-license e2fsprogs)))) (define-public strace (package -- cgit v1.2.3 From f57d263929ea9195d8ce34e89c9a37fb46adc6d2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 14:26:49 +0200 Subject: gnu: e2fsprogs: Install the libext2fs Info manual. * gnu/packages/linux.scm (e2fsprogs)[native-inputs]: Add TEXINFO. --- gnu/packages/linux.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index f04fd5ce6b..72b445f7a6 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -38,6 +38,7 @@ #:use-module (gnu packages attr) #:use-module (gnu packages xml) #:use-module (gnu packages autotools) + #:use-module (gnu packages texinfo) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) @@ -441,7 +442,8 @@ slabtop, and skill.") "0ibkkvp6kan0hn0d1anq4n2md70j5gcm7mwna515w82xwyr02rfw")))) (build-system gnu-build-system) (inputs `(("util-linux" ,util-linux))) - (native-inputs `(("pkg-config" ,pkg-config))) + (native-inputs `(("pkg-config" ,pkg-config) + ("texinfo" ,texinfo))) ; for the libext2fs Info manual (arguments '(#:phases (alist-cons-before 'configure 'patch-shells -- cgit v1.2.3 From 78214b4b89a4066ccbcdbaf9b9fb0a7d676e1a89 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 15:01:39 +0200 Subject: gnu: make-bootstrap: Add missing export. * gnu/packages/make-bootstrap.scm: Export '%guile-static-stripped'. The problem was hidden because of . --- gnu/packages/make-bootstrap.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/gnu/packages/make-bootstrap.scm b/gnu/packages/make-bootstrap.scm index 97a13b4b74..2e3e9ec4c1 100644 --- a/gnu/packages/make-bootstrap.scm +++ b/gnu/packages/make-bootstrap.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,7 +40,9 @@ %glibc-bootstrap-tarball %gcc-bootstrap-tarball %guile-bootstrap-tarball - %bootstrap-tarballs)) + %bootstrap-tarballs + + %guile-static-stripped)) ;;; Commentary: ;;; -- cgit v1.2.3 From 94e3029a834cb53a60dcef18556f8d207dea85cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 16:48:58 +0200 Subject: gnu: pius: Use Python 2. * gnu/packages/gnupg.scm (pius): Use Python 2. --- gnu/packages/gnupg.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm index f3fbef06fe..39f1ac0036 100644 --- a/gnu/packages/gnupg.scm +++ b/gnu/packages/gnupg.scm @@ -279,7 +279,7 @@ and every application benefits from this.") "1g1jly3wl4ks6h8ydkygyl2c4i7v3z91rg42005m6vm70y1d8b3d")))) (build-system gnu-build-system) (inputs `(("perl" ,perl) - ("python" ,python-wrapper) + ("python" ,python-2) ; uses the Python 2 'print' syntax ("gpg" ,gnupg))) (arguments `(#:tests? #f -- cgit v1.2.3 From 26a728eb091daf89a01986eac2d51dc8f0b58b6a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 18:09:25 +0200 Subject: linux-initrd: Delete files from the initrd ramfs when switching roots. * guix/build/linux-initrd.scm (switch-root): Delete file from the old root. Chdir to / after 'chroot' call. Re-open file descriptors 0, 1, and 2. (boot-system): Move 'loading' message after the 'switch-root' call. * gnu/system.scm (operating-system-boot-script): Add loop that closes file descriptor before calling 'execl'. --- gnu/system.scm | 9 +++++++++ guix/build/linux-initrd.scm | 48 ++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 54 insertions(+), 3 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index 65d1ca3418..8a5fe47b30 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -334,6 +334,15 @@ we're running in the final root." ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) + ;; Close any remaining open file descriptors to be on the + ;; safe side. This must be the very last thing we do, + ;; because Guile has internal FDs such as 'sleep_pipe' + ;; that need to be alive. + (let loop ((fd 3)) + (when (< fd 1024) + (false-if-exception (close-fdes fd)) + (loop (+ 1 fd)))) + ;; Start dmd. (execl (string-append #$dmd "/bin/dmd") "dmd" "--config" #$dmd-conf))))) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b133550bca..c09cdeafb4 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -286,9 +286,51 @@ run a file system check." util-linux' switch_root(8) does." (move-essential-file-systems root) (chdir root) - ;; TODO: Delete files from the old root. + + ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd. + ;; TODO: Use 'statfs' to check the fs type, like klibc does. + (when (or (not (file-exists? "/init")) (directory-exists? "/home")) + (format (current-error-port) + "The root file system is probably not an initrd; \ +bailing out.~%root contents: ~s~%" (scandir "/")) + (force-output (current-error-port)) + (exit 1)) + + ;; Delete files from the old root, without crossing mount points (assuming + ;; there are no mount points in sub-directories.) That means we're leaving + ;; the empty ROOT directory behind us, but that's OK. + (let ((root-device (stat:dev (stat "/")))) + (for-each (lambda (file) + (unless (member file '("." "..")) + (let* ((file (string-append "/" file)) + (device (stat:dev (lstat file)))) + (when (= device root-device) + (delete-file-recursively file))))) + (scandir "/"))) + + ;; Make ROOT the new root. (mount root "/" "" MS_MOVE) - (chroot ".")) + (chroot ".") + (chdir "/") + + (when (file-exists? "/dev/console") + ;; Close the standard file descriptors since they refer to the old + ;; /dev/console. + (for-each close-fdes '(0 1 2)) + + ;; Reopen them. + (let ((in (open-file "/dev/console" "rbl")) + (out (open-file "/dev/console" "wbl"))) + (dup2 (fileno in) 0) + (dup2 (fileno out) 1) + (dup2 (fileno out) 2) + + ;; Safely close IN and OUT. + (for-each (lambda (port) + (if (memv (fileno port) '(0 1 2)) + (set-port-revealed! port 1) + (close-port port))) + (list in out))))) (define* (boot-system #:key (linux-modules '()) @@ -393,8 +435,8 @@ to it are lost." (if to-load (begin - (format #t "loading '~a'...\n" to-load) (switch-root "/root") + (format #t "loading '~a'...\n" to-load) ;; Obviously this has to be done each time we boot. Do it from here ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) -- cgit v1.2.3 From 63016e7cd0c1a0a75dd40c44b4cf496aa3c85328 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 22:29:55 +0200 Subject: gnu: Add librsvg. * gnu/packages/gnome.scm (librsvg): New variable. --- gnu/packages/gnome.scm | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 221c16ca57..24f018d222 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -589,3 +589,71 @@ dealing with different structured file formats.") ;; LGPLv2.1-only. (license license:lgpl2.1))) + +(define-public librsvg + (package + (name "librsvg") + (version "2.40.2") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/librsvg/2.40/librsvg-" + version ".tar.xz")) + (sha256 + (base32 + "071959yjb2i1bja7ciy4bmpnd6fn2is9jjqsvvvnsqwl69j9n128")))) + (build-system gnu-build-system) + (arguments + `(#:modules ((guix build gnome) + (guix build gnu-build-system) + (guix build utils)) + #:imported-modules ((guix build gnome) + (guix build gnu-build-system) + (guix build utils)) + #:phases + (alist-cons-before + 'configure 'augment-gir-search-path + (lambda* (#:key inputs #:allow-other-keys) + (substitute* (find-files "." "Makefile\\.in") + (("INTROSPECTION_SCANNER_ARGS = ") + (string-append "INTROSPECTION_SCANNER_ARGS = " + "--add-include-path=" + (gir-directory inputs "gdk-pixbuf") + " ")) + (("INTROSPECTION_COMPILER_ARGS = ") + (string-append "INTROSPECTION_COMPILER_ARGS = " + "--includedir=" + (gir-directory inputs "gdk-pixbuf") + " "))) + + (substitute* "gdk-pixbuf-loader/Makefile.in" + ;; By default the gdk-pixbuf loader is installed under + ;; gdk-pixbuf's prefix. Work around that. + (("gdk_pixbuf_moduledir = .*$") + (string-append "gdk_pixbuf_moduledir = " + "$(prefix)/lib/gdk-pixbuf-2.0/2.0.10/" + "loaders\n")) + ;; Likewise, create a separate 'loaders.cache' file. + (("gdk_pixbuf_cache_file = .*$") + "gdk_pixbuf_cache_file = $(gdk_pixbuf_moduledir).cache\n"))) + %standard-phases))) + (native-inputs + `(("pkg-config" ,pkg-config) + ("gobject-introspection" ,gobject-introspection))) ; g-ir-compiler, etc. + (inputs + `(("pango" ,pango) + ("libcroco" ,libcroco) + ("bzip2" ,bzip2) + ("libgsf" ,libgsf) + ("libxml2" ,libxml2))) + (propagated-inputs + ;; librsvg-2.0.pc refers to all of that. + `(("cairo" ,cairo) + ("gdk-pixbuf" ,gdk-pixbuf) + ("glib" ,glib))) + (home-page "https://wiki.gnome.org/LibRsvg") + (synopsis "Render SVG files using Cairo") + (description + "librsvg is a C library to render SVG files using the Cairo 2D graphics +library.") + (license license:lgpl2.0+))) -- cgit v1.2.3 From 141aed808701351685de9d92532392384d730b37 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 22:40:33 +0200 Subject: gnu: gobject-introspection is usually meant to be a native input. * gnu/packages/gtk.scm (atk, pango, gdk-pixbuf, gtk+): Move gobject-introspection to 'native-inputs' since it's only used at build time. * gnu/packages/gnome.scm (libpeas): Move pkg-config, gobject-introspection, and intltool to 'native-inputs'. --- gnu/packages/gnome.scm | 9 +++++---- gnu/packages/gtk.scm | 25 +++++++++++++------------ 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 24f018d222..3e0ae80db2 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -458,11 +458,12 @@ some form of information without getting in the user's way.") `(("atk" ,atk) ("gdk-pixbuf" ,gdk-pixbuf) ("glib" ,glib) - ("gobject-introspection" ,gobject-introspection) ("gtk+" ,gtk+) - ("intltool" ,intltool) - ("pango" ,pango) - ("pkg-config" ,pkg-config))) + ("pango" ,pango))) + (native-inputs + `(("pkg-config" ,pkg-config) + ("gobject-introspection" ,gobject-introspection) + ("intltool" ,intltool))) (home-page "https://wiki.gnome.org/Libpeas") (synopsis "GObject plugin system") (description diff --git a/gnu/packages/gtk.scm b/gnu/packages/gtk.scm index fa92e5ab8c..cfe3dac476 100644 --- a/gnu/packages/gtk.scm +++ b/gnu/packages/gtk.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013 Andreas Enge -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -53,9 +53,10 @@ (base32 "1c2hbg66wfvibsz2ia0ri48yr62751fn950i97c53j3b0fjifsb3")))) (build-system gnu-build-system) - (inputs `(("glib" ,glib) - ("gobject-introspection" ,gobject-introspection))) - (native-inputs `(("pkg-config" ,pkg-config))) + (inputs `(("glib" ,glib))) + (native-inputs + `(("pkg-config" ,pkg-config) + ("gobject-introspection" ,gobject-introspection))) ; g-ir-compiler, etc. (synopsis "GNOME accessibility toolkit") (description "ATK provides the set of accessibility interfaces that are implemented @@ -156,10 +157,10 @@ affine transformation (scale, rotation, shear, etc.)") `(("cairo" ,cairo) ("harfbuzz" ,harfbuzz))) (inputs - `(("gobject-introspection" ,gobject-introspection) - ("zlib" ,zlib))) + `(("zlib" ,zlib))) (native-inputs - `(("pkg-config" ,pkg-config))) + `(("pkg-config" ,pkg-config) + ("gobject-introspection" ,gobject-introspection))) ; g-ir-compiler, etc. (synopsis "GNOME text and font handling library") (description "Pango is the core text and font handling library used in GNOME @@ -236,12 +237,12 @@ printing and other features typical of a source code editor.") (build-system gnu-build-system) (inputs `(("glib" ,glib) - ("gobject-introspection", gobject-introspection) ("libjpeg" ,libjpeg) ("libpng" ,libpng) ("libtiff" ,libtiff))) (native-inputs - `(("pkg-config" ,pkg-config))) + `(("pkg-config" ,pkg-config) + ("gobject-introspection", gobject-introspection))) ; g-ir-compiler, etc. (synopsis "GNOME image loading and manipulation library") (description "GdkPixbuf is a library for image loading and manipulation developed @@ -366,11 +367,11 @@ application suites.") ("libxinerama" ,libxinerama) ("pango" ,pango))) (inputs - `(("gobject-introspection" ,gobject-introspection) - ("libxml2" ,libxml2))) + `(("libxml2" ,libxml2))) (native-inputs - `(("perl" ,perl) + `(("perl" ,perl) ("pkg-config" ,pkg-config) + ("gobject-introspection" ,gobject-introspection) ("python-wrapper" ,python-wrapper) ("xorg-server" ,xorg-server))) (arguments -- cgit v1.2.3 From ce2df078d7b8e8d44b831270421513bd04429866 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 May 2014 23:10:11 +0200 Subject: gnu: Make $XDG_DATA_DIRS a search path variable for GLib. * gnu/packages/glib.scm (glib): Add 'native-search-paths' and 'search-paths' fields. * gnu/packages/gnome.scm (libpeas): Remove 'arguments' field. (librsvg)[arguments]: Remove #:modules and #:imported-modules. Remove settings of INTROSPECTION_SCANNER_ARGS and INTROSPECTION_COMPILER_ARGS in makefiles. * gnu/packages/gtk.scm (gtk+): Likewise. --- gnu/packages/glib.scm | 11 +++++++++++ gnu/packages/gnome.scm | 50 +------------------------------------------------- gnu/packages/gtk.scm | 36 +++--------------------------------- 3 files changed, 15 insertions(+), 82 deletions(-) diff --git a/gnu/packages/glib.scm b/gnu/packages/glib.scm index 49ffaa8f6e..77f21f95ce 100644 --- a/gnu/packages/glib.scm +++ b/gnu/packages/glib.scm @@ -160,6 +160,17 @@ shared NFS home directories.") ;; In 'gio/tests', 'gdbus-test-codegen-generated.h' is #included in a ;; file that gets compiled possibly before it has been fully generated. #:parallel-tests? #f)) + + (native-search-paths + ;; This variable is not really "owned" by GLib, but several related + ;; packages refer to it: gobject-introspection's tools use it as a search + ;; path for .gir files, and it's also a search path for schemas produced + ;; by 'glib-compile-schemas'. + (list (search-path-specification + (variable "XDG_DATA_DIRS") + (directories '("share"))))) + (search-paths native-search-paths) + (synopsis "Thread-safe general utility library; basis of GTK+ and GNOME") (description "GLib provides data structure handling for C, portability wrappers, diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 3e0ae80db2..e889c9bff0 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -424,36 +424,6 @@ some form of information without getting in the user's way.") (base32 "13fzyzv6c0cfdj83z1s16lv8k997wpnzyzr0wfwcfkcmvz64g1q0")))) (build-system gnu-build-system) - (arguments - `(#:modules ((guix build gnome) - (guix build gnu-build-system) - (guix build utils)) - #:imported-modules ((guix build gnome) - (guix build gnu-build-system) - (guix build utils)) - #:phases - (alist-replace - 'configure - (lambda* (#:key inputs #:allow-other-keys #:rest args) - (let ((configure (assoc-ref %standard-phases 'configure))) - (substitute* "libpeas-gtk/Makefile.in" - (("--add-include-path") - (string-append - " --add-include-path=" (gir-directory inputs "atk") - " --add-include-path=" (gir-directory inputs "gdk-pixbuf") - " --add-include-path=" (gir-directory inputs "gtk+") - " --add-include-path=" (gir-directory inputs "pango") - " --add-include-path"))) - (substitute* "libpeas-gtk/Makefile.in" - (("--includedir=\\$\\(top_builddir") - (string-append - " --includedir=" (gir-directory inputs "atk") - " --includedir=" (gir-directory inputs "gdk-pixbuf") - " --includedir=" (gir-directory inputs "gtk+") - " --includedir=" (gir-directory inputs "pango") - " --includedir=$(top_builddir"))) - (apply configure args))) - %standard-phases))) (inputs `(("atk" ,atk) ("gdk-pixbuf" ,gdk-pixbuf) @@ -605,28 +575,10 @@ dealing with different structured file formats.") "071959yjb2i1bja7ciy4bmpnd6fn2is9jjqsvvvnsqwl69j9n128")))) (build-system gnu-build-system) (arguments - `(#:modules ((guix build gnome) - (guix build gnu-build-system) - (guix build utils)) - #:imported-modules ((guix build gnome) - (guix build gnu-build-system) - (guix build utils)) - #:phases + `(#:phases (alist-cons-before 'configure 'augment-gir-search-path (lambda* (#:key inputs #:allow-other-keys) - (substitute* (find-files "." "Makefile\\.in") - (("INTROSPECTION_SCANNER_ARGS = ") - (string-append "INTROSPECTION_SCANNER_ARGS = " - "--add-include-path=" - (gir-directory inputs "gdk-pixbuf") - " ")) - (("INTROSPECTION_COMPILER_ARGS = ") - (string-append "INTROSPECTION_COMPILER_ARGS = " - "--includedir=" - (gir-directory inputs "gdk-pixbuf") - " "))) - (substitute* "gdk-pixbuf-loader/Makefile.in" ;; By default the gdk-pixbuf loader is installed under ;; gdk-pixbuf's prefix. Work around that. diff --git a/gnu/packages/gtk.scm b/gnu/packages/gtk.scm index cfe3dac476..7600103da3 100644 --- a/gnu/packages/gtk.scm +++ b/gnu/packages/gtk.scm @@ -375,13 +375,7 @@ application suites.") ("python-wrapper" ,python-wrapper) ("xorg-server" ,xorg-server))) (arguments - `(#:modules ((guix build gnome) - (guix build gnu-build-system) - (guix build utils)) - #:imported-modules ((guix build gnome) - (guix build gnu-build-system) - (guix build utils)) - #:phases + `(#:phases (alist-replace 'configure (lambda* (#:key inputs #:allow-other-keys #:rest args) @@ -392,32 +386,8 @@ application suites.") ;; directory. ;; See the manual page for dbus-uuidgen to correct this issue. (substitute* "testsuite/Makefile.in" - (("SUBDIRS = gdk gtk a11y css reftests") "SUBDIRS = gdk")) - - ;; We need to tell GIR where it can find some of the required .gir - ;; files. - (substitute* "gdk/Makefile.in" - (("--add-include-path=../gdk") - (string-append - "--add-include-path=../gdk" - " --add-include-path=" (gir-directory inputs "gdk-pixbuf") - " --add-include-path=" (gir-directory inputs "pango"))) - (("--includedir=\\.") - (string-append "--includedir=." - " --includedir=" (gir-directory inputs "gdk-pixbuf") - " --includedir=" (gir-directory inputs "pango")))) - - (substitute* "gtk/Makefile.in" - (("--add-include-path=../gdk") - (string-append "--add-include-path=../gdk" - " --add-include-path=" (gir-directory inputs "atk") - " --add-include-path=" (gir-directory inputs "gdk-pixbuf") - " --add-include-path=" (gir-directory inputs "pango"))) - (("--includedir=../gdk") - (string-append "--includedir=../gdk" - " --includedir=" (gir-directory inputs "atk") - " --includedir=" (gir-directory inputs "gdk-pixbuf") - " --includedir=" (gir-directory inputs "pango")))) + (("SUBDIRS = gdk gtk a11y css reftests") + "SUBDIRS = gdk")) (apply configure args))) %standard-phases))))) -- cgit v1.2.3 From 538cc2e0165a32d3c5de9022f522f37880b60f5d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 May 2014 14:32:36 +0200 Subject: Remove now unneeded (guix build gnome) module. * guix/build/gnome.scm: Remove. * Makefile.am (MODULES): Update accordingly. --- Makefile.am | 1 - guix/build/gnome.scm | 31 ------------------------------- 2 files changed, 32 deletions(-) delete mode 100644 guix/build/gnome.scm diff --git a/Makefile.am b/Makefile.am index 22bbdca13c..14e9e4a4b6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -59,7 +59,6 @@ MODULES = \ guix/build/download.scm \ guix/build/cmake-build-system.scm \ guix/build/git.scm \ - guix/build/gnome.scm \ guix/build/gnu-build-system.scm \ guix/build/gnu-dist.scm \ guix/build/linux-initrd.scm \ diff --git a/guix/build/gnome.scm b/guix/build/gnome.scm deleted file mode 100644 index cac4de8f24..0000000000 --- a/guix/build/gnome.scm +++ /dev/null @@ -1,31 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Cyril Roelandt -;;; -;;; 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 . - -(define-module (guix build gnome) - #:export (gir-directory)) - -;;; Commentary: -;;; -;;; Tools commonly used when building GNOME programs. -;;; -;;; Code: - -(define (gir-directory inputs pkg-name) - "Return the GIR directory name for PKG-NAME found from INPUTS." - (string-append (assoc-ref inputs pkg-name) - "/share/gir-1.0")) -- cgit v1.2.3 From b1995341ce803c396068a6e41f8cd64b09bbf2f6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 00:22:26 +0200 Subject: linux-initrd: Update /etc/mtab. * guix/build/linux-initrd.scm (mount-root-file-system): Populate /root/etc/mtab. (mount-file-system): Update ROOT/etc/mtab. --- guix/build/linux-initrd.scm | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index c09cdeafb4..6dd7c6e958 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -228,7 +228,9 @@ UNIONFS." (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) - (start-repl)))) + (start-repl))) + + (copy-file "/proc/mounts" "/root/etc/mtab")) (define (check-file-system device type) "Run a file system check of TYPE on DEVICE." @@ -279,7 +281,14 @@ run a file system check." (mount source mount-point type (flags->bit-mask flags) (if options (string->pointer options) - %null-pointer)))))) + %null-pointer)) + + ;; Update /etc/mtab. + (mkdir-p (string-append root "/etc")) + (let ((port (open-output-file (string-append root "/etc/mtab")))) + (format port "~a ~a ~a ~a 0 0~%" + source mount-point type options) + (close-port port)))))) (define (switch-root root) "Switch to ROOT as the root file system, in a way similar to what -- cgit v1.2.3 From a29a09fc29b15e20e4178e9adcb07a961e6b6c2a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 18:38:03 +0200 Subject: Change 'nix-upstream' submodule URL. * .gitmodules: Use https, not http. Reported by Pjotr Prins . --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 0c3b046608..dcc4462652 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "nix-upstream"] path = nix-upstream - url = http://github.com/NixOS/nix.git + url = https://github.com/NixOS/nix.git -- cgit v1.2.3 From fb0e3709280639fce796edc0f3fa8e0d1a6de46d Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 1 May 2014 12:16:16 -0500 Subject: gnu: Add OpenMPI * gnu/packages/mpi.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. --- gnu-system.am | 1 + gnu/packages/mpi.scm | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+) create mode 100644 gnu/packages/mpi.scm diff --git a/gnu-system.am b/gnu-system.am index 5ebcf67d5c..b4aec2549e 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -154,6 +154,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/moe.scm \ gnu/packages/mpd.scm \ gnu/packages/mp3.scm \ + gnu/packages/mpi.scm \ gnu/packages/multiprecision.scm \ gnu/packages/mtools.scm \ gnu/packages/mysql.scm \ diff --git a/gnu/packages/mpi.scm b/gnu/packages/mpi.scm new file mode 100644 index 0000000000..14626acbb0 --- /dev/null +++ b/gnu/packages/mpi.scm @@ -0,0 +1,66 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier +;;; +;;; 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 . + +(define-module (gnu packages mpi) + #:use-module (guix packages) + #:use-module (guix licenses) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module (gnu packages) + #:use-module (gnu packages gcc) + #:use-module (srfi srfi-1)) + +(define-public openmpi + (package + (name "openmpi") + (version "1.8.1") + (source + (origin + (method url-fetch) + (uri (string-append "http://www.open-mpi.org/softawre/ompi/v" + (string-join (take (string-split version #\.) 2) + ".") + "/downloads/openmpi-" version ".tar.bz2")) + (sha256 + (base32 + "13z1q69f3qwmmhpglarfjminfy2yw4rfqr9jydjk5507q3mjf50p")))) + (build-system gnu-build-system) + (propagated-inputs + `(("gfortran" ,gfortran-4.8))) + (arguments + `(#:configure-flags '("--enable-static" + "--enable-oshmem" + ;; Thread support causes some applications to hang + ;; "--enable-event-thread-support" + ;; "--enable-opal-multi-threads" + ;; "--enable-orte-progress-threads" + ;; "--enable-mpi-thread-multiple" + "--enable-mpi-ext=all" + "--with-devel-headers"))) + (home-page "http://www.open-mpi.org") + (synopsis "Open source MPI-2 implementation") + (description + "The Open MPI Project is an open source MPI-2 implementation that is +developed and maintained by a consortium of academic, research, and industry +partners. Open MPI is therefore able to combine the expertise, technologies, +and resources from all across the High Performance Computing community in +order to build the best MPI library available. Open MPI offers advantages for +system and software vendors, application developers and computer science +researchers.") + ;; See file://LICENSE + (license bsd-2))) -- cgit v1.2.3 From 10b11968c8af4e107daed35251e14f7238b43d42 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 8 May 2014 11:39:59 -0500 Subject: gnu: petsc: Clean some more leaked chroot references * gnu/packages/maths.scm (petsc)[arguments]: Scrub some config-generated header files before build. Only remove files if they exist. --- gnu/packages/maths.scm | 58 ++++++++++++++++++++++++++++---------------------- 1 file changed, 33 insertions(+), 25 deletions(-) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 2018e1706f..b83788a67c 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -420,32 +420,40 @@ ASCII text files using Gmsh's own scripting language.") (format #t "configure flags: ~s~%" flags) (zero? (apply system* "./configure" flags)))) (alist-cons-after - 'install 'clean-local-references - ;; Try to keep installed files from leaking build directory names. + 'configure 'clean-local-references + ;; Try to keep build directory names from leaking into compiled code (lambda* (#:key inputs outputs #:allow-other-keys) - (let ((out (assoc-ref outputs "out")) - (fortran (assoc-ref inputs "gfortran"))) - (substitute* (map (lambda (file) - (string-append out "/" file)) - '("conf/petscvariables" - "conf/PETScConfig.cmake" - "include/petscconf.h" - "include/petscmachineinfo.h")) - (((getcwd)) out)) - ;; Make compiler references point to the store - (substitute* (string-append out "/conf/petscvariables") - (("= g(cc|\\+\\+|fortran)" _ suffix) - (string-append "= " fortran "/bin/g" suffix))) - ;; PETSc installs some build logs, which aren't necessary. - (for-each (lambda (file) - (delete-file (string-append out "/" file))) - '("conf/configure.log" - "conf/make.log" - "conf/test.log" - "conf/RDict.db" - ;; Once installed, should uninstall with Guix - "conf/uninstall.py")))) - %standard-phases)))) + (let ((out (assoc-ref outputs "out"))) + (substitute* (find-files "." "^petsc(conf|machineinfo).h$") + (((getcwd)) out)))) + (alist-cons-after + 'install 'clean-install + ;; Try to keep installed files from leaking build directory names. + (lambda* (#:key inputs outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out")) + (fortran (assoc-ref inputs "gfortran"))) + (substitute* (map (lambda (file) + (string-append out "/" file)) + '("conf/petscvariables" + "conf/PETScConfig.cmake")) + (((getcwd)) out)) + ;; Make compiler references point to the store + (substitute* (string-append out "/conf/petscvariables") + (("= g(cc|\\+\\+|fortran)" _ suffix) + (string-append "= " fortran "/bin/g" suffix))) + ;; PETSc installs some build logs, which aren't necessary. + (for-each (lambda (file) + (let ((f (string-append out "/" file))) + (when (file-exists? f) + (delete-file f)))) + '("conf/configure.log" + "conf/make.log" + "conf/test.log" + "conf/error.log" + "conf/RDict.db" + ;; Once installed, should uninstall with Guix + "conf/uninstall.py")))) + %standard-phases))))) (home-page "http://www.mcs.anl.gov/petsc") (synopsis "Library to solve ODEs and algebraic equations") (description "PETSc, pronounced PET-see (the S is silent), is a suite of -- cgit v1.2.3 From d8c7eeb996c433b1744a1404e1fc1e5f987589a1 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 8 May 2014 12:33:47 -0500 Subject: gnu: Add petsc-openmpi. * gnu/packages/maths.scm (petsc-openmpi): New variable. (petsc-complex-openmpi): New variable. --- gnu/packages/maths.scm | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index b83788a67c..4e8c67746d 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -45,6 +45,7 @@ #:use-module (gnu packages less) #:use-module (gnu packages xorg) #:use-module (gnu packages gl) + #:use-module (gnu packages mpi) #:use-module (gnu packages multiprecision) #:use-module (gnu packages pcre) #:use-module (gnu packages perl) @@ -473,6 +474,40 @@ scientific applications modeled by partial differential equations.") (string-append (package-description petsc) " Complex scalar type version.")))) +(define-public petsc-openmpi + (package (inherit petsc) + (name "petsc-openmpi") + (inputs + `(("openmpi" ,openmpi) + ,@(package-inputs petsc))) + (arguments + (substitute-keyword-arguments (package-arguments petsc) + ((#:configure-flags cf) + ``("--with-mpiexec=mpirun" + ,(string-append "--with-mpi-dir=" + (assoc-ref %build-inputs "openmpi")) + ,@(delete "--with-mpi=0" ,cf))))) + (description + (string-append (package-description petsc) + " With OpenMPI parallelism support.")))) + +(define-public petsc-complex-openmpi + (package (inherit petsc-complex) + (name "petsc-complex-openmpi") + (inputs + `(("openmpi" ,openmpi) + ,@(package-inputs petsc-complex))) + (arguments + (substitute-keyword-arguments (package-arguments petsc-complex) + ((#:configure-flags cf) + ``("--with-mpiexec=mpirun" + ,(string-append "--with-mpi-dir=" + (assoc-ref %build-inputs "openmpi")) + ,@(delete "--with-mpi=0" ,cf))))) + (description + (string-append (package-description petsc-complex) + " With OpenMPI parallelism support.")))) + (define-public superlu (package (name "superlu") -- cgit v1.2.3 From 8ede638c4b84d5e26844fdc5726992ed78244cfd Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 8 May 2014 14:48:59 -0500 Subject: gnu: openmpi: Avoid "open source" verbiage * gnu/packages/mpi.scm (openmpi)[synopsis,description]: Remove mention of "open source". --- gnu/packages/mpi.scm | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/gnu/packages/mpi.scm b/gnu/packages/mpi.scm index 14626acbb0..eae5722078 100644 --- a/gnu/packages/mpi.scm +++ b/gnu/packages/mpi.scm @@ -53,14 +53,13 @@ "--enable-mpi-ext=all" "--with-devel-headers"))) (home-page "http://www.open-mpi.org") - (synopsis "Open source MPI-2 implementation") + (synopsis "MPI-2 implementation") (description - "The Open MPI Project is an open source MPI-2 implementation that is -developed and maintained by a consortium of academic, research, and industry -partners. Open MPI is therefore able to combine the expertise, technologies, -and resources from all across the High Performance Computing community in -order to build the best MPI library available. Open MPI offers advantages for -system and software vendors, application developers and computer science -researchers.") + "The Open MPI Project is an MPI-2 implementation that is developed and +maintained by a consortium of academic, research, and industry partners. Open +MPI is therefore able to combine the expertise, technologies, and resources +from all across the High Performance Computing community in order to build the +best MPI library available. Open MPI offers advantages for system and +software vendors, application developers and computer science researchers.") ;; See file://LICENSE (license bsd-2))) -- cgit v1.2.3 From 03178aec1dc63c630374b1aed2178140c185b9f5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 19:44:44 +0200 Subject: git-download: Disable TLS certificate verification. * guix/build/git.scm (git-fetch): Add 'setenv' call. --- guix/build/git.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/guix/build/git.scm b/guix/build/git.scm index 4245594c38..68b132265b 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -31,6 +31,11 @@ #:key (git-command "git")) "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit identifier. Return #t on success, #f otherwise." + + ;; Disable TLS certificate verification. The hash of the checkout is known + ;; in advance anyway. + (setenv "GIT_SSL_NO_VERIFY" "true") + (and (zero? (system* git-command "clone" url directory)) (with-directory-excursion directory (system* git-command "tag" "-l") -- cgit v1.2.3 From ef4ab0a4c55f47e581e7a47622061f1583676d1e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 21:50:53 +0200 Subject: doc: Mention Kiselyov's work on "staging". * doc/guix.texi (G-Expressions): Mention Oleg's work on "staging" in footnote. --- doc/guix.texi | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index e127b0f76a..2aacf5d9b6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1995,10 +1995,14 @@ build the derivations; they are run by the daemon in a container It should come as no surprise that we like to write those build actions in Scheme. When we do that, we end up with two @dfn{strata} of Scheme code@footnote{The term @dfn{stratum} in this context was coined by -Manuel Serrano et al.@: in the context of their work on Hop.}: the -``host code''---code that defines packages, talks to the daemon, -etc.---and the ``build code''---code that actually performs build -actions, such as making directories, invoking @command{make}, etc. +Manuel Serrano et al.@: in the context of their work on Hop. Oleg +Kiselyov, who has written insightful +@url{http://okmij.org/ftp/meta-programming/#meta-scheme, essays and code +on this topic}, refers to this kind of code generation as +@dfn{staging}.}: the ``host code''---code that defines packages, talks +to the daemon, etc.---and the ``build code''---code that actually +performs build actions, such as making directories, invoking +@command{make}, etc. To describe a derivation and its build actions, one typically needs to embed build code inside host code. It boils down to manipulating build -- cgit v1.2.3 From 474b832d5e596c5f0713afbcdea5a19c6770cfac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 23:21:45 +0200 Subject: linux-initrd: Don't leak /dev/console file descriptors. * guix/build/linux-initrd.scm (switch-root): Simplify /dev/console code. This fixes a bug where we would leak the IN and OUT file descriptors. --- guix/build/linux-initrd.scm | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 6dd7c6e958..16c741f931 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -324,22 +324,15 @@ bailing out.~%root contents: ~s~%" (scandir "/")) (when (file-exists? "/dev/console") ;; Close the standard file descriptors since they refer to the old - ;; /dev/console. - (for-each close-fdes '(0 1 2)) - - ;; Reopen them. - (let ((in (open-file "/dev/console" "rbl")) - (out (open-file "/dev/console" "wbl"))) - (dup2 (fileno in) 0) - (dup2 (fileno out) 1) - (dup2 (fileno out) 2) - - ;; Safely close IN and OUT. - (for-each (lambda (port) - (if (memv (fileno port) '(0 1 2)) - (set-port-revealed! port 1) - (close-port port))) - (list in out))))) + ;; /dev/console, and reopen them. + (let ((console (open-file "/dev/console" "r+b0"))) + (for-each close-fdes '(0 1 2)) + + (dup2 (fileno console) 0) + (dup2 (fileno console) 1) + (dup2 (fileno console) 2) + + (close-port console)))) (define* (boot-system #:key (linux-modules '()) -- cgit v1.2.3 From a00dd9fbf41f694f93f588e2182921de12e592c4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 May 2014 23:41:40 +0200 Subject: services: Add service to cleanly unmount the root file system. * gnu/services/base.scm (root-file-system-service, user-processes-service): New procedures. (mingetty-service, nscd-service, syslog-service, guix-service): Add requirement on 'user-processes'. (%base-services): Add (user-processes-service) and (root-file-system-service). * gnu/services/xorg.scm (slim-service): Add requirement on 'user-processes'. --- gnu/services/base.scm | 93 ++++++++++++++++++++++++++++++++++++++++++++++++--- gnu/services/xorg.scm | 2 +- 2 files changed, 90 insertions(+), 5 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 9561995243..ae538ea41c 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -22,14 +22,17 @@ #:use-module (gnu system linux) ; 'pam-service', etc. #:use-module (gnu packages admin) #:use-module ((gnu packages base) - #:select (glibc-final)) + #:select (glibc-final %final-inputs)) + #:use-module (gnu packages linux) #:use-module (gnu packages package-management) #:use-module (guix gexp) #:use-module (guix monads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 format) - #:export (host-name-service + #:export (root-file-system-service + user-processes-service + host-name-service mingetty-service nscd-service syslog-service @@ -43,6 +46,81 @@ ;;; ;;; Code: +(define (root-file-system-service) + "Return a service whose sole purpose is to re-mount read-only the root file +system upon shutdown (aka. cleanly \"umounting\" root.) + +This service must be the root of the service dependency graph so that its +'stop' action is invoked when dmd is the only process left." + (define coreutils + (car (assoc-ref %final-inputs "coreutils"))) + + (with-monad %store-monad + (return + (service + (documentation "Take care of the root file system.") + (provision '(root-file-system)) + (start #~(const #t)) + (stop #~(lambda _ + ;; Return #f if successfully stopped. + (system* (string-append #$coreutils "/bin/sync")) + + (call-with-blocked-asyncs + (lambda () + (let ((null (%make-void-port "w"))) + ;; Close 'dmd.log'. + (display "closing log\n") + ;; XXX: Ideally we'd use 'stop-logging', but that one + ;; doesn't actually close the port as of dmd 0.1. + (close-port (@@ (dmd comm) log-output-port)) + (set! (@@ (dmd comm) log-output-port) null) + + ;; Redirect the default output ports.. + (set-current-output-port null) + (set-current-error-port null) + + ;; Close /dev/console. + (for-each close-fdes '(0 1 2)) + + ;; At this points, there are no open files left, so the + ;; root file system can be re-mounted read-only. + (not (zero? + (system* (string-append #$util-linux "/bin/mount") + "-n" "-o" "remount,ro" + "-t" "dummy" "dummy" "/")))))))) + (respawn? #f))))) + +(define* (user-processes-service #:key (grace-delay 2)) + "Return the service that is responsible for terminating all the processes so +that the root file system can be re-mounted read-only, just before +rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM +has been sent are terminated with SIGKILL. + +All the services that spawn processes must depend on this one so that they are +stopped before 'kill' is called." + (with-monad %store-monad + (return (service + (documentation "When stopped, terminate all user processes.") + (provision '(user-processes)) + (requirement '(root-file-system)) + (start #~(const #t)) + (stop #~(lambda _ + ;; When this happens, all the processes have been + ;; killed, including 'deco', so DMD-OUTPUT-PORT and + ;; thus CURRENT-OUTPUT-PORT are dangling. + (call-with-output-file "/dev/console" + (lambda (port) + (display "sending all processes the TERM signal\n" + port))) + + (kill -1 SIGTERM) + (sleep #$grace-delay) + (kill -1 SIGKILL) + + (display "all processes have been terminated\n") + #f)) + (respawn? #f))))) + (define (host-name-service name) "Return a service that sets the host name to NAME." (with-monad %store-monad @@ -66,7 +144,7 @@ ;; Since the login prompt shows the host name, wait for the 'host-name' ;; service to be done. - (requirement '(host-name)) + (requirement '(user-processes host-name)) (start #~(make-forkexec-constructor (string-append #$mingetty "/sbin/mingetty") @@ -87,6 +165,7 @@ (return (service (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) + (requirement '(user-processes)) (start #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") "-f" "/dev/null" @@ -126,6 +205,7 @@ (service (documentation "Run the syslog daemon (syslogd).") (provision '(syslogd)) + (requirement '(user-processes)) (start #~(make-forkexec-constructor (string-append #$inetutils "/libexec/syslogd") @@ -161,6 +241,7 @@ BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." #:gid build-user-gid))) (return (service (provision '(guix-daemon)) + (requirement '(user-processes)) (start #~(make-forkexec-constructor (string-append #$guix "/bin/guix-daemon") @@ -189,6 +270,10 @@ This is the GNU operating system, welcome!\n\n"))) (nscd-service) ;; FIXME: Make this an activation-time thing instead of a service. - (host-name-service "gnu")))) + (host-name-service "gnu") + + ;; The "root" services. + (user-processes-service) + (root-file-system-service)))) ;;; base.scm ends here diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index e47b33c9b8..db1d808715 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -161,7 +161,7 @@ reboot_cmd " dmd "/sbin/reboot (service (documentation "Xorg display server") (provision '(xorg-server)) - (requirement '(host-name)) + (requirement '(user-processes host-name)) (start ;; XXX: Work around the inability to specify env. vars. directly. #~(make-forkexec-constructor -- cgit v1.2.3 From 2cf287df596fb3490f0313c324b5c70ee5cb3aa7 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 8 May 2014 16:45:43 -0500 Subject: gnu: fftw: Upgrade to 3.3.4 * gnu/packages/algebra.scm (fftw): Upgrade to 3.3.4. --- gnu/packages/algebra.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/algebra.scm b/gnu/packages/algebra.scm index 0318cb531e..b7e067af00 100644 --- a/gnu/packages/algebra.scm +++ b/gnu/packages/algebra.scm @@ -196,14 +196,14 @@ syntax is similar to that of C, so basic usage is familiar. It also includes (define-public fftw (package (name "fftw") - (version "3.3.3") + (version "3.3.4") (source (origin (method url-fetch) (uri (string-append "ftp://ftp.fftw.org/pub/fftw/fftw-" version".tar.gz")) (sha256 (base32 - "1wwp9b2va7vkq3ay7a9jk22nr4x5q6m37rzqy2j8y3d11c5grkc5")))) + "10h9mzjxnwlsjziah4lri85scc05rlajz39nqf3mbh4vja8dw34g")))) (build-system gnu-build-system) (arguments '(#:configure-flags '("--enable-shared" "--enable-openmp") -- cgit v1.2.3 From 0fc54d4b319ede932e5978f672ea095e89711605 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 8 May 2014 16:54:06 -0500 Subject: gnu: fftw: Add dependency on openmpi. * gnu/packages/algebra.scm (fftw)[inputs,arguments]: Add OpenMPI. --- gnu/packages/algebra.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/gnu/packages/algebra.scm b/gnu/packages/algebra.scm index b7e067af00..7d2d50cc75 100644 --- a/gnu/packages/algebra.scm +++ b/gnu/packages/algebra.scm @@ -21,6 +21,7 @@ (define-module (gnu packages algebra) #:use-module (gnu packages) #:use-module (gnu packages multiprecision) + #:use-module (gnu packages mpi) #:use-module (gnu packages perl) #:use-module (gnu packages readline) #:use-module (gnu packages flex) @@ -206,7 +207,7 @@ syntax is similar to that of C, so basic usage is familiar. It also includes "10h9mzjxnwlsjziah4lri85scc05rlajz39nqf3mbh4vja8dw34g")))) (build-system gnu-build-system) (arguments - '(#:configure-flags '("--enable-shared" "--enable-openmp") + '(#:configure-flags '("--enable-shared" "--enable-openmp" "--enable-mpi") #:phases (alist-cons-before 'build 'no-native (lambda _ @@ -218,6 +219,7 @@ syntax is similar to that of C, so basic usage is familiar. It also includes (("-mtune=native") ""))) %standard-phases))) (native-inputs `(("perl" ,perl))) + (inputs `(("openmpi" ,openmpi))) (home-page "http://fftw.org") (synopsis "Computing the discrete Fourier transform") (description -- cgit v1.2.3 From 85a84cbd83b90d132035c3b20456bd241e0ef86d Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 8 May 2014 17:06:46 -0500 Subject: gnu: openmpi: Fix typo in download uri * gnu/packages/mpi.scm (openmpi)[origin]: Fix typo. --- gnu/packages/mpi.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnu/packages/mpi.scm b/gnu/packages/mpi.scm index eae5722078..eea218799d 100644 --- a/gnu/packages/mpi.scm +++ b/gnu/packages/mpi.scm @@ -32,7 +32,7 @@ (source (origin (method url-fetch) - (uri (string-append "http://www.open-mpi.org/softawre/ompi/v" + (uri (string-append "http://www.open-mpi.org/software/ompi/v" (string-join (take (string-split version #\.) 2) ".") "/downloads/openmpi-" version ".tar.bz2")) -- cgit v1.2.3 From 67b660037c21c5c7071c01406524f32331851877 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 May 2014 14:55:12 +0200 Subject: gnu: Add numactl. * gnu/packages/linux.scm (numactl): New variable. --- gnu/packages/linux.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index 72b445f7a6..bcef394244 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -1031,3 +1031,59 @@ UnionFS-FUSE additionally supports copy-on-write.") '(#:tests? #f #:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static"))) (inputs `(("fuse" ,fuse-static))))) + +(define-public numactl + (package + (name "numactl") + (version "2.0.9") + (source (origin + (method url-fetch) + (uri (string-append + "ftp://oss.sgi.com/www/projects/libnuma/download/numactl-" + version + ".tar.gz")) + (sha256 + (base32 + "073myxlyyhgxh1w3r757ajixb7s2k69czc3r0g12c3scq7k3784w")))) + (build-system gnu-build-system) + (arguments + '(#:phases (alist-replace + 'configure + (lambda* (#:key outputs #:allow-other-keys) + ;; There's no 'configure' script, just a raw makefile. + (substitute* "Makefile" + (("^prefix := .*$") + (string-append "prefix := " (assoc-ref outputs "out") + "\n")) + (("^libdir := .*$") + ;; By default the thing tries to install under + ;; $prefix/lib64 when on a 64-bit platform. + (string-append "libdir := $(prefix)/lib\n")))) + %standard-phases) + + #:make-flags (list + ;; By default the thing tries to use 'cc'. + "CC=gcc" + + ;; Make sure programs have an RPATH so they can find + ;; libnuma.so. + (string-append "LDLIBS=-Wl,-rpath=" + (assoc-ref %outputs "out") "/lib")) + + ;; There's a 'test' target, but it requires NUMA support in the kernel + ;; to run, which we can't assume to have. + #:tests? #f)) + (home-page "http://oss.sgi.com/projects/libnuma/") + (synopsis "Tools for non-uniform memory access (NUMA) machines") + (description + "NUMA stands for Non-Uniform Memory Access, in other words a system whose +memory is not all in one place. The numactl program allows you to run your +application program on specific CPU's and memory nodes. It does this by +supplying a NUMA memory policy to the operating system before running your +program. + +The package contains other commands, such as numademo, numastat and memhog. +The numademo command provides a quick overview of NUMA performance on your +system.") + (license (list gpl2 ; programs + lgpl2.1)))) ; library -- cgit v1.2.3 From 42422cc2f1c9c05c7bfb075a8bc360b8bb7eaee4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 May 2014 15:23:41 +0200 Subject: gnu: Add pciutils. * gnu/packages/pciutils.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. --- gnu-system.am | 1 + gnu/packages/pciutils.scm | 91 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 92 insertions(+) create mode 100644 gnu/packages/pciutils.scm diff --git a/gnu-system.am b/gnu-system.am index b4aec2549e..fa8f6f7ec5 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -173,6 +173,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/parallel.scm \ gnu/packages/parted.scm \ gnu/packages/patchutils.scm \ + gnu/packages/pciutils.scm \ gnu/packages/pcre.scm \ gnu/packages/pdf.scm \ gnu/packages/pem.scm \ diff --git a/gnu/packages/pciutils.scm b/gnu/packages/pciutils.scm new file mode 100644 index 0000000000..2b887f16d8 --- /dev/null +++ b/gnu/packages/pciutils.scm @@ -0,0 +1,91 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu packages pciutils) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module ((guix licenses) + #:renamer (symbol-prefix-proc 'license:)) + #:use-module (guix build-system gnu) + #:use-module (gnu packages compression) + #:use-module (gnu packages pkg-config) + #:use-module (gnu packages which)) + +(define-public pciutils + (package + (name "pciutils") + (version "3.2.0") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://kernel.org/software/utils/pciutils/pciutils-" + version + ".tar.bz2")) + (sha256 + (base32 + "0d9as9jzjjg5c1nwf58z1y1i7rf9fqxmww1civckhcvcn0xr85mq")))) + (build-system gnu-build-system) + (arguments + '(#:phases (alist-replace + 'configure + (lambda* (#:key outputs #:allow-other-keys) + ;; There's no 'configure' script, just a raw makefile. + (substitute* "Makefile" + (("^PREFIX=.*$") + (string-append "PREFIX := " (assoc-ref outputs "out") + "\n")) + (("^MANDIR:=.*$") + ;; By default the thing tries to automatically + ;; determine whether to use $prefix/man or + ;; $prefix/share/man, and wrongly so. + (string-append "MANDIR := " (assoc-ref outputs "out") + "/share/man\n")) + (("^SHARED=.*$") + ;; Build libpciutils.so. + "SHARED := yes\n") + (("^ZLIB=.*$") + ;; Ask for zlib support. + "ZLIB := yes\n"))) + + (alist-replace + 'install + (lambda* (#:key outputs #:allow-other-keys) + ;; Install the commands, library, and .pc files. + (zero? (system* "make" "install" "install-lib"))) + %standard-phases)) + + ;; Make sure programs have an RPATH so they can find libpciutils.so. + #:make-flags (list (string-append "LDFLAGS=-Wl,-rpath=" + (assoc-ref %outputs "out") "/lib")) + + ;; No test suite. + #:tests? #f)) + (native-inputs + `(("which" ,which) + ("pkg-config" ,pkg-config))) + (inputs + ;; TODO: Add dependency on Linux libkmod. + `(("zlib" ,zlib))) + (home-page "http://mj.ucw.cz/sw/pciutils/") + (synopsis "Programs for inspecting and manipulating PCI devices") + (description + "The PCI Utilities are a collection of programs for inspecting and +manipulating configuration of PCI devices, all based on a common portable +library libpci which offers access to the PCI configuration space on a variety +of operating systems. This includes the 'lspci' and 'setpci' commands.") + (license license:gpl2+))) -- cgit v1.2.3 From 2b0d560a3f41d9973c53ac03cf3531f9e4cab0ad Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 May 2014 15:49:08 +0200 Subject: gnu: Add hwloc. * gnu/packages/mpi.scm (hwloc): New variable. (openmpi): Add TODO comment. --- gnu/packages/mpi.scm | 57 +++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 56 insertions(+), 1 deletion(-) diff --git a/gnu/packages/mpi.scm b/gnu/packages/mpi.scm index eea218799d..071229214b 100644 --- a/gnu/packages/mpi.scm +++ b/gnu/packages/mpi.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Eric Bavier +;;; Copyright © 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,13 +19,66 @@ (define-module (gnu packages mpi) #:use-module (guix packages) - #:use-module (guix licenses) + #:use-module ((guix licenses) + #:hide (expat)) #:use-module (guix download) #:use-module (guix build-system gnu) #:use-module (gnu packages) #:use-module (gnu packages gcc) + #:use-module (gnu packages linux) + #:use-module (gnu packages pciutils) + #:use-module (gnu packages xorg) + #:use-module (gnu packages gtk) + #:use-module (gnu packages xml) + #:use-module (gnu packages ncurses) + #:use-module (gnu packages pkg-config) #:use-module (srfi srfi-1)) +(define-public hwloc + (package + (name "hwloc") + (version "1.9") + (source (origin + (method url-fetch) + (uri (string-append "http://www.open-mpi.org/software/hwloc/v" + version "/downloads/hwloc-" + version ".tar.bz2")) + (sha256 + (base32 + "0zjgiili2a8v63s8ly3a8qp8ibxv1jw3zbgm7diic3w1qgqiza14")))) + (build-system gnu-build-system) + (arguments + ;; Enable libpci support, which effectively makes hwloc GPLv2+. + '(#:configure-flags '("--enable-libpci"))) + (inputs + `(("numactl" ,numactl) + ("libx11" ,libx11) + ("cairo" ,cairo) + ("ncurses" ,ncurses) + ("expat" ,expat))) + (native-inputs + `(("pkg-config" ,pkg-config))) + (propagated-inputs + ;; 'hwloc.pc' refers to libpci, hence the propagation. + `(("pciutils" ,pciutils))) + (home-page "http://www.open-mpi.org/projects/hwloc/") + (synopsis "Abstraction of hardware architectures") + (description + "hwloc provides a portable abstraction (across OS, +versions, architectures, ...) of the hierarchical topology of modern +architectures, including NUMA memory nodes, sockets, shared caches, cores and +simultaneous multithreading. It also gathers various attributes such as cache +and memory information. It primarily aims at helping high-performance +computing applications with gathering information about the hardware so as to +exploit it accordingly and efficiently. + +hwloc may display the topology in multiple convenient formats. It also offers +a powerful programming interface to gather information about the hardware, +bind processes, and much more.") + + ;; But see above about linking against libpci. + (license bsd-3))) + (define-public openmpi (package (name "openmpi") @@ -40,6 +94,7 @@ (base32 "13z1q69f3qwmmhpglarfjminfy2yw4rfqr9jydjk5507q3mjf50p")))) (build-system gnu-build-system) + ;; TODO: Use our hwloc instead of the bundled one. (propagated-inputs `(("gfortran" ,gfortran-4.8))) (arguments -- cgit v1.2.3 From e5c66f8c7bfb1f8c4162d19b3d01526164cfe2a4 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Fri, 9 May 2014 08:59:47 -0500 Subject: gnu: fftw: Factor out OpenMPI dependency. * gnu/packages/algebra.scm (fftw)[inputs,arguments]: Remove OpenMPI. (fftw-openmpi): New variable. --- gnu/packages/algebra.scm | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/gnu/packages/algebra.scm b/gnu/packages/algebra.scm index 7d2d50cc75..9ed978536d 100644 --- a/gnu/packages/algebra.scm +++ b/gnu/packages/algebra.scm @@ -207,7 +207,7 @@ syntax is similar to that of C, so basic usage is familiar. It also includes "10h9mzjxnwlsjziah4lri85scc05rlajz39nqf3mbh4vja8dw34g")))) (build-system gnu-build-system) (arguments - '(#:configure-flags '("--enable-shared" "--enable-openmp" "--enable-mpi") + '(#:configure-flags '("--enable-shared" "--enable-openmp") #:phases (alist-cons-before 'build 'no-native (lambda _ @@ -219,7 +219,6 @@ syntax is similar to that of C, so basic usage is familiar. It also includes (("-mtune=native") ""))) %standard-phases))) (native-inputs `(("perl" ,perl))) - (inputs `(("openmpi" ,openmpi))) (home-page "http://fftw.org") (synopsis "Computing the discrete Fourier transform") (description @@ -239,3 +238,17 @@ cosine/ sine transforms or DCT/DST).") (description (string-append (package-description fftw) " Single-precision version.")))) + +(define-public fftw-openmpi + (package (inherit fftw) + (name "fftw-openmpi") + (inputs + `(("openmpi" ,openmpi) + ,@(package-inputs fftw))) + (arguments + (substitute-keyword-arguments (package-arguments fftw) + ((#:configure-flags cf) + `(cons "--enable-mpi" ,cf)))) + (description + (string-append (package-description fftw) + " With OpenMPI parallelism support.")))) -- cgit v1.2.3 From 217a5b852e02775123a30131f63684c09bd6ac77 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 May 2014 22:58:46 +0200 Subject: system: Automatically add essential services. * gnu/services/base.scm (%base-services): Remove calls to 'host-name-service', 'user-processes-service', and 'root-file-system-service'. * gnu/system.scm ()[operating-system-services]: Rename to... [operating-system-user-services]: ... this. (essential-services, operating-system-services): New procedures. (operating-system-accounts, operating-system-etc-directory, operating-system-boot-script, operating-system-derivation): Adjust to new 'operating-system-services' return type. --- gnu/services/base.scm | 9 +-------- gnu/system.scm | 31 ++++++++++++++++++++++++------- 2 files changed, 25 insertions(+), 15 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index ae538ea41c..5157349aec 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -267,13 +267,6 @@ This is the GNU operating system, welcome!\n\n"))) (mingetty-service "tty6" #:motd motd) (syslog-service) (guix-service) - (nscd-service) - - ;; FIXME: Make this an activation-time thing instead of a service. - (host-name-service "gnu") - - ;; The "root" services. - (user-processes-service) - (root-file-system-service)))) + (nscd-service)))) ;;; base.scm ends here diff --git a/gnu/system.scm b/gnu/system.scm index 8a5fe47b30..491e0ed7ae 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -40,6 +40,7 @@ #:export (operating-system operating-system? operating-system-services + operating-system-user-services operating-system-packages operating-system-bootloader-entries operating-system-host-name @@ -50,7 +51,6 @@ operating-system-packages operating-system-timezone operating-system-locale - operating-system-services operating-system-file-systems operating-system-derivation @@ -112,7 +112,7 @@ (timezone operating-system-timezone) ; string (locale operating-system-locale) ; string - (services operating-system-services ; list of monadic services + (services operating-system-user-services ; list of monadic services (default %base-services)) (pam-services operating-system-pam-services ; list of PAM services @@ -184,6 +184,24 @@ file." (gexp->derivation name builder)) +(define (essential-services os) + "Return the list of essential services for OS. These are special services +that implement part of what's declared in OS are responsible for low-level +bookkeeping." + (mlet %store-monad ((procs (user-processes-service)) + (root-fs (root-file-system-service)) + (host-name (host-name-service + (operating-system-host-name os)))) + (return (list host-name procs root-fs)))) + +(define (operating-system-services os) + "Return all the services of OS, including \"internal\" services that do not +explicitly appear in OS." + (mlet %store-monad + ((user (sequence %store-monad (operating-system-user-services os))) + (essential (essential-services os))) + (return (append essential user)))) + (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") (accounts '()) @@ -254,8 +272,7 @@ alias ll='ls -l' (define (operating-system-accounts os) "Return the user accounts for OS, including an obligatory 'root' account." - (mlet %store-monad ((services (sequence %store-monad - (operating-system-services os)))) + (mlet %store-monad ((services (operating-system-services os))) (return (cons (user-account (name "root") (password "") @@ -269,7 +286,7 @@ alias ll='ls -l' (define (operating-system-etc-directory os) "Return that static part of the /etc directory of OS." (mlet* %store-monad - ((services (sequence %store-monad (operating-system-services os))) + ((services (operating-system-services os)) (pam-services -> ;; Services known to PAM. (delete-duplicates @@ -310,7 +327,7 @@ we're running in the final root." (guix build utils))) (mlet* %store-monad - ((services (sequence %store-monad (operating-system-services os))) + ((services (operating-system-services os)) (etc (operating-system-etc-directory os)) (modules (imported-modules %modules)) (compiled (compiled-modules %modules)) @@ -367,7 +384,7 @@ we're running in the final root." (mlet* %store-monad ((profile (operating-system-profile os)) (etc (operating-system-etc-directory os)) - (services (sequence %store-monad (operating-system-services os))) + (services (operating-system-services os)) (boot (operating-system-boot-script os)) (kernel -> (operating-system-kernel os)) (initrd ((operating-system-initrd os) boot-file-systems)) -- cgit v1.2.3 From 02139eb9b2bdbe1b342a0550dd8725a764716c28 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 21:47:05 +0200 Subject: linux-initrd: Append to /etc/mtab. * guix/build/linux-initrd.scm (mount-file-system): Open /etc/mtab in append mode. --- guix/build/linux-initrd.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 16c741f931..83636dfd73 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -285,7 +285,7 @@ run a file system check." ;; Update /etc/mtab. (mkdir-p (string-append root "/etc")) - (let ((port (open-output-file (string-append root "/etc/mtab")))) + (let ((port (open-file (string-append root "/etc/mtab") "a"))) (format port "~a ~a ~a ~a 0 0~%" source mount-point type options) (close-port port)))))) -- cgit v1.2.3 From 29fa45f45d3192ad0f8d2c46523d7a7d6422c9e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 21:49:11 +0200 Subject: Add (guix build syscalls). * guix/build/syscalls.scm, tests/syscalls.scm: New files. * Makefile.am (MODULES): Add guix/build/syscalls.scm. (SCM_TESTS): Add tests/syscalls.scm. * guix/utils.scm (%libc-errno-pointer, errno): Remove; take from (guix build syscalls). --- Makefile.am | 4 +- guix/build/syscalls.scm | 156 ++++++++++++++++++++++++++++++++++++++++++++++++ guix/utils.scm | 33 +--------- tests/syscalls.scm | 47 +++++++++++++++ 4 files changed, 207 insertions(+), 33 deletions(-) create mode 100644 guix/build/syscalls.scm create mode 100644 tests/syscalls.scm diff --git a/Makefile.am b/Makefile.am index 14e9e4a4b6..20bf650c9b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -71,6 +71,7 @@ MODULES = \ guix/build/svn.scm \ guix/build/vm.scm \ guix/build/activation.scm \ + guix/build/syscalls.scm \ guix/packages.scm \ guix/snix.scm \ guix/scripts/download.scm \ @@ -143,7 +144,8 @@ SCM_TESTS = \ tests/gexp.scm \ tests/nar.scm \ tests/union.scm \ - tests/profiles.scm + tests/profiles.scm \ + tests/syscalls.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm new file mode 100644 index 0000000000..90cacc760b --- /dev/null +++ b/guix/build/syscalls.scm @@ -0,0 +1,156 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix build syscalls) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:export (errno + MS_RDONLY + MS_REMOUNT + MS_BIND + MS_MOVE + mount + umount)) + +;;; Commentary: +;;; +;;; This module provides bindings to libc's syscall wrappers. It uses the +;;; FFI, and thus requires a dynamically-linked Guile. (For statically-linked +;;; Guile, we instead apply 'guile-linux-syscalls.patch'.) +;;; +;;; Code: + +(define %libc-errno-pointer + ;; Glibc's 'errno' pointer. + (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) + (and errno-loc + (let ((proc (pointer->procedure '* errno-loc '()))) + (proc))))) + +(define errno + (if %libc-errno-pointer + (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) + (lambda () + "Return the current errno." + ;; XXX: We assume that nothing changes 'errno' while we're doing all this. + ;; In particular, that means that no async must be running here. + + ;; Use one of the fixed-size native-ref procedures because they are + ;; optimized down to a single VM instruction, which reduces the risk + ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.) + (let-syntax ((ref (lambda (s) + (syntax-case s () + ((_ bv) + (case (sizeof int) + ((4) + #'(bytevector-s32-native-ref bv 0)) + ((8) + #'(bytevector-s64-native-ref bv 0)) + (else + (error "unsupported 'int' size" + (sizeof int))))))))) + (ref bv)))) + (lambda () 0))) + +(define (augment-mtab source target type options) + "Augment /etc/mtab with information about the given mount point." + (let ((port (open-file "/etc/mtab" "a"))) + (format port "~a ~a ~a ~a 0 0~%" + source target type (or options "rw")) + (close-port port))) + +(define (read-mtab port) + "Read an mtab-formatted file from PORT, returning a list of tuples." + (let loop ((result '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse result) + (loop (cons (string-tokenize line) result)))))) + +(define (remove-from-mtab target) + "Remove mount point TARGET from /etc/mtab." + (define entries + (remove (match-lambda + ((device mount-point type options freq passno) + (string=? target mount-point)) + (_ #f)) + (call-with-input-file "/etc/fstab" read-mtab))) + + (call-with-output-file "/etc/fstab" + (lambda (port) + (for-each (match-lambda + ((device mount-point type options freq passno) + (format port "~a ~a ~a ~a ~a ~a~%" + device mount-point type options freq passno))) + entries)))) + +;; Linux mount flags, from libc's . +(define MS_RDONLY 1) +(define MS_REMOUNT 32) +(define MS_BIND 4096) +(define MS_MOVE 8192) + +(define mount + (let* ((ptr (dynamic-func "mount" (dynamic-link))) + (proc (pointer->procedure int ptr `(* * * ,unsigned-long *)))) + (lambda* (source target type #:optional (flags 0) options + #:key (update-mtab? #t)) + "Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS +may be a bitwise-or of the MS_* constants, and OPTIONS may be a +string. When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored. When +UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error' exception on +error." + (let ((ret (proc (if source + (string->pointer source) + %null-pointer) + (string->pointer target) + (if type + (string->pointer type) + %null-pointer) + flags + (if options + (string->pointer options) + %null-pointer))) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "mount" "mount ~S on ~S: ~A" + (list source target (strerror err)) + (list err))) + (when update-mtab? + (augment-mtab source target type options)))))) + +(define umount + (let* ((ptr (dynamic-func "umount2" (dynamic-link))) + (proc (pointer->procedure int ptr `(* ,int)))) + (lambda* (target #:optional (flags 0) + #:key (update-mtab? #t)) + "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* +constants from ." + (let ((ret (proc (string->pointer target) flags)) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "umount" "~S: ~A" + (list target (strerror err)) + (list err))) + (when update-mtab? + (remove-from-mtab target)))))) + +;;; syscalls.scm ends here diff --git a/guix/utils.scm b/guix/utils.scm index 53fc68d27b..700a191d71 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -28,6 +28,7 @@ #:use-module (rnrs bytevectors) #:use-module ((rnrs io ports) #:select (put-bytevector)) #:use-module ((guix build utils) #:select (dump-port)) + #:use-module ((guix build syscalls) #:select (errno)) #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) @@ -366,38 +367,6 @@ that goes to PORT according to COMPRESSION, a symbol such as 'xz." ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu (else #(1 2 3))))) ; *-gnu* -(define %libc-errno-pointer - ;; Glibc's 'errno' pointer. - (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) - (and errno-loc - (let ((proc (pointer->procedure '* errno-loc '()))) - (proc))))) - -(define errno - (if %libc-errno-pointer - (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) - (lambda () - "Return the current errno." - ;; XXX: We assume that nothing changes 'errno' while we're doing all this. - ;; In particular, that means that no async must be running here. - - ;; Use one of the fixed-size native-ref procedures because they are - ;; optimized down to a single VM instruction, which reduces the risk - ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.) - (let-syntax ((ref (lambda (s) - (syntax-case s () - ((_ bv) - (case (sizeof int) - ((4) - #'(bytevector-s32-native-ref bv 0)) - ((8) - #'(bytevector-s64-native-ref bv 0)) - (else - (error "unsupported 'int' size" - (sizeof int))))))))) - (ref bv)))) - (lambda () 0))) - (define fcntl-flock (let* ((ptr (dynamic-func "fcntl" (dynamic-link))) (proc (pointer->procedure int ptr `(,int ,int *)))) diff --git a/tests/syscalls.scm b/tests/syscalls.scm new file mode 100644 index 0000000000..5243ac9a34 --- /dev/null +++ b/tests/syscalls.scm @@ -0,0 +1,47 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-syscalls) + #:use-module (guix build syscalls) + #:use-module (srfi srfi-64)) + +;; Test the (guix build syscalls) module, although there's not much that can +;; actually be tested without being root. + +(test-begin "syscalls") + +(test-equal "mount, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (mount "/dev/null" "/does-not-exist" "ext2") + #f) + (compose system-error-errno list))) + +(test-equal "umount, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (umount "/does-not-exist") + #f) + (compose system-error-errno list))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From 23ed63a12d941ad836f3fc9902ba4f145db1975c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 22:58:22 +0200 Subject: services: Use (guix build syscalls) instead of util-linux. * gnu/services/dmd.scm (dmd-configuration-file): Add derivations for the (guix build syscalls) module, and add that to the load path of dmd.conf. * gnu/services/base.scm (root-file-system-service): Rewrite using the 'sync' and 'mount' procedures. --- gnu/services/base.scm | 19 ++++++++--------- gnu/services/dmd.scm | 56 +++++++++++++++++++++++++++++++-------------------- 2 files changed, 42 insertions(+), 33 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 5157349aec..e0f2888ee0 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -22,8 +22,7 @@ #:use-module (gnu system linux) ; 'pam-service', etc. #:use-module (gnu packages admin) #:use-module ((gnu packages base) - #:select (glibc-final %final-inputs)) - #:use-module (gnu packages linux) + #:select (glibc-final)) #:use-module (gnu packages package-management) #:use-module (guix gexp) #:use-module (guix monads) @@ -52,9 +51,6 @@ system upon shutdown (aka. cleanly \"umounting\" root.) This service must be the root of the service dependency graph so that its 'stop' action is invoked when dmd is the only process left." - (define coreutils - (car (assoc-ref %final-inputs "coreutils"))) - (with-monad %store-monad (return (service @@ -63,7 +59,7 @@ This service must be the root of the service dependency graph so that its (start #~(const #t)) (stop #~(lambda _ ;; Return #f if successfully stopped. - (system* (string-append #$coreutils "/bin/sync")) + (sync) (call-with-blocked-asyncs (lambda () @@ -82,12 +78,13 @@ This service must be the root of the service dependency graph so that its ;; Close /dev/console. (for-each close-fdes '(0 1 2)) - ;; At this points, there are no open files left, so the + ;; At this point, there are no open files left, so the ;; root file system can be re-mounted read-only. - (not (zero? - (system* (string-append #$util-linux "/bin/mount") - "-n" "-o" "remount,ro" - "-t" "dummy" "dummy" "/")))))))) + (mount #f "/" #f + (logior MS_REMOUNT MS_RDONLY) + #:update-mtab? #f) + + #f))))) (respawn? #f))))) (define* (user-processes-service #:key (grace-delay 2)) diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 161a971edd..8d4c483cc4 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -32,27 +32,39 @@ (define (dmd-configuration-file services) "Return the dmd configuration file for SERVICES." - (define config - #~(begin - (use-modules (ice-9 ftw)) - - (register-services - #$@(map (lambda (service) - #~(make - #:docstring '#$(service-documentation service) - #:provides '#$(service-provision service) - #:requires '#$(service-requirement service) - #:respawn? '#$(service-respawn? service) - #:start #$(service-start service) - #:stop #$(service-stop service))) - services)) - - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") - - (format #t "starting services...~%") - (for-each start '#$(append-map service-provision services)))) - - (gexp->file "dmd.conf" config)) + (define modules + ;; Extra modules visible to dmd.conf. + '((guix build syscalls))) + + (mlet %store-monad ((modules (imported-modules modules)) + (compiled (compiled-modules modules))) + (define config + #~(begin + (eval-when (expand load eval) + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons #$compiled %load-compiled-path))) + + (use-modules (ice-9 ftw) + (guix build syscalls)) + + (register-services + #$@(map (lambda (service) + #~(make + #:docstring '#$(service-documentation service) + #:provides '#$(service-provision service) + #:requires '#$(service-requirement service) + #:respawn? '#$(service-respawn? service) + #:start #$(service-start service) + #:stop #$(service-stop service))) + services)) + + ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. + (setenv "PATH" "/run/current-system/bin") + + (format #t "starting services...~%") + (for-each start '#$(append-map service-provision services)))) + + (gexp->file "dmd.conf" config))) ;;; dmd.scm ends here -- cgit v1.2.3 From 023f391c7860d21aee9e9b3e601d7a81bb5d128d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 23:33:52 +0200 Subject: services: Add 'file-system-service'. * gnu/services/base.scm (file-system-service): New procedure. (user-processes-service): Add 'requirements' parameter. * gnu/services/dmd.scm (dmd-configuration-file): Use (guix build linux-initrd). * guix/build/linux-initrd.scm (guix): Export 'check-file-system'. * gnu/system.scm (file-union): New procedure. (essential-services): Use it. Add that to the returned list. --- gnu/services/base.scm | 30 ++++++++++++++++++++++++++++-- gnu/services/dmd.scm | 8 ++++++-- gnu/system.scm | 30 +++++++++++++++++++++++++----- guix/build/linux-initrd.scm | 1 + 4 files changed, 60 insertions(+), 9 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index e0f2888ee0..6431a3aaba 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -30,6 +30,7 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 format) #:export (root-file-system-service + file-system-service user-processes-service host-name-service mingetty-service @@ -87,19 +88,44 @@ This service must be the root of the service dependency graph so that its #f))))) (respawn? #f))))) -(define* (user-processes-service #:key (grace-delay 2)) +(define* (file-system-service device target type + #:key (check? #t) options) + "Return a service that mounts DEVICE on TARGET as a file system TYPE with +OPTIONS. When CHECK? is true, check the file system before mounting it." + (with-monad %store-monad + (return + (service + (provision (list (symbol-append 'file-system- (string->symbol target)))) + (requirement '(root-file-system)) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + #$(if check? + #~(check-file-system #$device #$type) + #~#t) + (mount #$device #$target #$type 0 #$options) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + (umount #$target) + #f)))))) + +(define* (user-processes-service requirements #:key (grace-delay 2)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM has been sent are terminated with SIGKILL. +The returned service will depend on 'root-file-system' and on all the services +listed in REQUIREMENTS. + All the services that spawn processes must depend on this one so that they are stopped before 'kill' is called." (with-monad %store-monad (return (service (documentation "When stopped, terminate all user processes.") (provision '(user-processes)) - (requirement '(root-file-system)) + (requirement (cons 'root-file-system requirements)) (start #~(const #t)) (stop #~(lambda _ ;; When this happens, all the processes have been diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 8d4c483cc4..0d17285890 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -34,7 +34,9 @@ "Return the dmd configuration file for SERVICES." (define modules ;; Extra modules visible to dmd.conf. - '((guix build syscalls))) + '((guix build syscalls) + (guix build linux-initrd) + (guix build utils))) (mlet %store-monad ((modules (imported-modules modules)) (compiled (compiled-modules modules))) @@ -46,7 +48,9 @@ (cons #$compiled %load-compiled-path))) (use-modules (ice-9 ftw) - (guix build syscalls)) + (guix build syscalls) + ((guix build linux-initrd) + #:select (check-file-system))) (register-services #$@(map (lambda (service) diff --git a/gnu/system.scm b/gnu/system.scm index 491e0ed7ae..d76c3670f0 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -184,15 +184,35 @@ file." (gexp->derivation name builder)) +(define (other-file-system-services os) + "Return file system services for the file systems of OS that are not marked +as 'needed-for-boot'." + (define file-systems + (remove (lambda (fs) + (or (file-system-needed-for-boot? fs) + (string=? "/" (file-system-mount-point fs)))) + (operating-system-file-systems os))) + + (sequence %store-monad + (map (match-lambda + (($ device target type flags opts #f check?) + (file-system-service device target type + #:check? check? + #:options opts))) + file-systems))) + (define (essential-services os) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level bookkeeping." - (mlet %store-monad ((procs (user-processes-service)) - (root-fs (root-file-system-service)) - (host-name (host-name-service - (operating-system-host-name os)))) - (return (list host-name procs root-fs)))) + (mlet* %store-monad ((root-fs (root-file-system-service)) + (other-fs (other-file-system-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 other-fs)))) (define (operating-system-services os) "Return all the services of OS, including \"internal\" services that do not diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 83636dfd73..0c3b2f0d9f 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,6 +30,7 @@ linux-command-line make-essential-device-nodes configure-qemu-networking + check-file-system mount-file-system bind-mount load-linux-module* -- cgit v1.2.3 From f3bde2ff9f19a542ccceea40e3750e1e478f245e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 May 2014 23:56:45 +0200 Subject: vm: Fix recently-introduced regression in 'operating-system-services' use. * gnu/system/vm.scm (operating-system-build-gid): Adjust to new return type of 'operating-system-services' introduced in 217a5b8. --- gnu/system/vm.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b20831f44d..2520853205 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -255,14 +255,14 @@ such as /etc files." (define (operating-system-build-gid os) "Return as a monadic value the group id for build users of OS, or #f." - (anym %store-monad - (lambda (service) - (and (equal? '(guix-daemon) - (service-provision service)) - (match (service-user-groups service) - ((group) - (user-group-id group))))) - (operating-system-services os))) + (mlet %store-monad ((services (operating-system-services os))) + (return (any (lambda (service) + (and (equal? '(guix-daemon) + (service-provision service)) + (match (service-user-groups service) + ((group) + (user-group-id group))))) + services)))) (define (operating-system-default-contents os) "Return a list of directives suitable for 'system-qemu-image' describing the -- cgit v1.2.3 From af8a56b8a292bb06ac48779e9f0494519617e7d0 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sun, 11 May 2014 10:43:51 +0200 Subject: doc: Add a section on perl modules in the packaging guidelines. * doc/guix.texi (Perl modules): New section explaining the naming of perl modules. --- doc/guix.texi | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 2aacf5d9b6..82e713c0c9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11,7 +11,7 @@ @copying Copyright @copyright{} 2012, 2013, 2014 Ludovic Courtès@* -Copyright @copyright{} 2013 Andreas Enge@* +Copyright @copyright{} 2013, 2014 Andreas Enge@* Copyright @copyright{} 2013 Nikita Karetnikov Permission is granted to copy, distribute and/or modify this document @@ -2751,6 +2751,7 @@ needed is to review and apply the patch. * Package Naming:: What's in a name? * Version Numbers:: When the name is not enough. * Python Modules:: Taming the snake. +* Perl Modules:: Little pearls. @end menu @node Software Freedom @@ -2796,8 +2797,8 @@ Both are usually the same and correspond to the lowercase conversion of the project name chosen upstream. For instance, the GNUnet project is packaged as @code{gnunet}. We do not add @code{lib} prefixes for library packages, unless these are already part of the official project name. But see -@ref{Python Modules} for special rules concerning modules for -the Python language. +@pxref{Python Modules} and @ref{Perl Modules} for special rules concerning +modules for the Python and Perl languages. @node Version Numbers @@ -2859,6 +2860,19 @@ for instance, the module python-dateutil is packaged under the names @code{python-dateutil} and @code{python2-dateutil}. +@node Perl Modules +@subsection Perl Modules + +Perl programs standing for themselves are named as any other package, +using the lowercase upstream name. +For Perl packages containing a single class, we use the lowercase class name, +replace all occurrences of @code{::} by dashes and prepend the prefix +@code{perl-}. +So the class @code{XML::Parser} becomes @code{perl-xml-parser}. +Modules containing several classes keep their lowercase upstream name and +are also prepended by @code{perl-}. Such modules tend to have the word +@code{perl} somewhere in their name, which gets dropped in favor of the +prefix. For instance, @code{libwww-perl} becomes @code{perl-libwww}. -- cgit v1.2.3 From d0c64188b68cceb93e6a61eba123dac5e47e2c0f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 11 May 2014 12:11:09 +0200 Subject: doc: Mention upgrades that trigger a lot of rebuilds. * HACKING (Commit Access): Mention upgrades that trigger a lot rebuilds. --- HACKING | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/HACKING b/HACKING index 6600397554..9e47b9703b 100644 --- a/HACKING +++ b/HACKING @@ -159,7 +159,8 @@ patches include fixing typos, etc.) For patches that just add a new package, and a simple one, it’s OK to commit, if you’re confident (which means you successfully built it in a chroot setup, and have done a reasonable copyright and license auditing.) Likewise for -package upgrades. We have a mailing list for commit notifications +package upgrades, except upgrades that trigger a lot of rebuilds (for example, +upgrading GnuTLS or GLib.) We have a mailing list for commit notifications (guix-commits@gnu.org), so people can notice. Before pushing your changes, make sure to run ‘git pull --rebase’. -- cgit v1.2.3 From 7e0c23fb3e232ddb3cbcb9c115618b25840eccde Mon Sep 17 00:00:00 2001 From: John Darrington Date: Sun, 11 May 2014 07:27:38 +0200 Subject: gnu: pspp: Upgrade to 0.8.3 * gnu/packages/maths.scm (pspp): Update to 0.8.3. --- gnu/packages/maths.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 4e8c67746d..49fdacef04 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -145,7 +145,7 @@ LP/MIP solver is included in the package.") (define-public pspp (package (name "pspp") - (version "0.8.2") + (version "0.8.3") (source (origin (method url-fetch) @@ -153,7 +153,7 @@ LP/MIP solver is included in the package.") version ".tar.gz")) (sha256 (base32 - "1w7h3dglgx0jlq1wb605b8pgfsk2vr1q2q2rj7bsajh9ihbcsixr")))) + "0vri2pzvmm38qaihfvwlry30f40lcnps4blg59ixic4q20ldxf5d")))) (build-system gnu-build-system) (inputs `(("cairo" ,cairo) -- cgit v1.2.3 From 057d6ce5e42d813b9d5e49ddae5d88e6581cc1d8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 11 May 2014 13:41:08 +0200 Subject: services: xorg: Fix harmless typo in slim.cfg. * gnu/services/xorg.scm (slim-service): Add missing whitespace in XINITRC invocation. --- gnu/services/xorg.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index db1d808715..1988cfa6a0 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -147,7 +147,7 @@ authfile /var/run/slim.auth # The login command. '%session' is replaced by the chosen session name, one # of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. -login_cmd exec " xinitrc "%session +login_cmd exec " xinitrc " %session sessions wmaker,ratpoison halt_cmd " dmd "/sbin/halt -- cgit v1.2.3 From ab6a279abbfa39b1e1bec0e363744d241972f844 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 11 May 2014 22:41:01 +0200 Subject: system: Make accounts and groups at activation time. * gnu/services/base.scm (guix-build-accounts): Remove #:gid parameter; add #:group. Remove 'password' and 'gid' fields in 'user-account' form, and add 'group'. (guix-service): Remove #:build-user-gid parameter. Remove 'id' field in 'user-group' form. * gnu/system.scm (etc-directory): Remove #:groups and #:accounts. No longer produce files "passwd", "shadow", and "group". Adjust caller accordingly. (%root-account): New variable. (operating-system-accounts): Add 'users' variable. Add %ROOT-ACCOUNT only of 'operating-system-users' doesn't already contain a root account. (user-group->gexp, user-account->gexp): New procedures. (operating-system-boot-script): Add calls to 'setenv' and 'activate-users+groups' in gexp. * gnu/system/linux.scm (base-pam-services): Add PAM services for "user{add,del,mode}" and "group{add,del,mod}". * gnu/system/shadow.scm ()[gid]: Rename to... [group]: ... this. [supplementary-groups]: New field. [uid, password]: Default to #f. ()[id]: Default to #f. (group-file, passwd-file): Remove. * gnu/system/vm.scm (operating-system-default-contents)[user-directories]: Remove. Add "/home" to the directives. * guix/build/activation.scm (add-group, add-user, activate-users+groups): New procedures. --- build-aux/hydra/demo-os.scm | 3 +- gnu/services/base.scm | 10 ++--- gnu/system.scm | 95 +++++++++++++++++++++++++++++--------------- gnu/system/linux.scm | 14 ++++--- gnu/system/shadow.scm | 61 +++++----------------------- gnu/system/vm.scm | 15 +------ guix/build/activation.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++- 7 files changed, 186 insertions(+), 109 deletions(-) diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 03449abda2..4116c063f4 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -45,7 +45,8 @@ (locale "en_US.UTF-8") (users (list (user-account (name "guest") - (uid 1000) (gid 100) + (group "wheel") + (password "") (comment "Guest of GNU") (home-directory "/home/guest")))) (groups (list (user-group (name "root") (id 0)) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 6431a3aaba..1f5ff3e4cb 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -237,8 +237,8 @@ stopped before 'kill' is called." (stop #~(make-kill-destructor)))))) (define* (guix-build-accounts count #:key + (group "guixbuild") (first-uid 30001) - (gid 30000) (shadow shadow)) "Return a list of COUNT user accounts for Guix build users, with UIDs starting at FIRST-UID, and under GID." @@ -247,9 +247,8 @@ starting at FIRST-UID, and under GID." (lambda (n) (user-account (name (format #f "guixbuilder~2,'0d" n)) - (password "!") (uid (+ first-uid n -1)) - (gid gid) + (group group) (comment (format #f "Guix Build User ~2d" n)) (home-directory "/var/empty") (shell #~(string-append #$shadow "/sbin/nologin")))) @@ -257,11 +256,11 @@ starting at FIRST-UID, and under GID." 1)))) (define* (guix-service #:key (guix guix) (builder-group "guixbuild") - (build-user-gid 30000) (build-accounts 10)) + (build-accounts 10)) "Return a service that runs the build daemon from GUIX, and has BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." (mlet %store-monad ((accounts (guix-build-accounts build-accounts - #:gid build-user-gid))) + #:group builder-group))) (return (service (provision '(guix-daemon)) (requirement '(user-processes)) @@ -274,7 +273,6 @@ BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." (user-accounts accounts) (user-groups (list (user-group (name builder-group) - (id build-user-gid) (members (map user-account-name user-accounts))))))))) diff --git a/gnu/system.scm b/gnu/system.scm index d76c3670f0..bd69532a89 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -224,17 +224,12 @@ explicitly appear in OS." (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") - (accounts '()) - (groups '()) (pam-services '()) (profile "/var/run/current-system/profile") (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad - ((passwd (passwd-file accounts)) - (shadow (passwd-file accounts #:shadow? #t)) - (group (group-file groups)) - (pam.d (pam-services->directory pam-services)) + ((pam.d (pam-services->directory pam-services)) (sudoers (text-file "sudoers" sudoers)) (login.defs (text-file "login.defs" "# Empty for now.\n")) (shells (text-file "shells" ; used by xterm and others @@ -278,10 +273,6 @@ alias ll='ls -l' ("profile" ,#~#$bashrc) ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" #$timezone)) - ("passwd" ,#~#$passwd) - ("shadow" ,#~#$shadow) - ("group" ,#~#$group) - ("sudoers" ,#~#$sudoers))))) (define (operating-system-profile os) @@ -290,18 +281,28 @@ alias ll='ls -l' (union (operating-system-packages os) #:name "default-profile")) +(define %root-account + ;; Default root account. + (user-account + (name "root") + (password "") + (uid 0) (group "root") + (comment "System administrator") + (home-directory "/root"))) + (define (operating-system-accounts os) "Return the user accounts for OS, including an obligatory 'root' account." + (define users + ;; Make sure there's a root account. + (if (find (lambda (user) + (and=> (user-account-uid user) zero?)) + (operating-system-users os)) + (operating-system-users os) + (cons %root-account (operating-system-users os)))) + (mlet %store-monad ((services (operating-system-services os))) - (return (cons (user-account - (name "root") - (password "") - (uid 0) (gid 0) - (comment "System administrator") - (home-directory "/root")) - (append (operating-system-users os) - (append-map service-user-accounts - services)))))) + (return (append users + (append-map service-user-accounts services))))) (define (operating-system-etc-directory os) "Return that static part of the /etc directory of OS." @@ -312,12 +313,8 @@ alias ll='ls -l' (delete-duplicates (append (operating-system-pam-services os) (append-map service-pam-services services)))) - (accounts (operating-system-accounts os)) - (profile-drv (operating-system-profile os)) - (groups -> (append (operating-system-groups os) - (append-map service-user-groups services)))) - (etc-directory #:accounts accounts #:groups groups - #:pam-services pam-services + (profile-drv (operating-system-profile os))) + (etc-directory #:pam-services pam-services #:locale (operating-system-locale os) #:timezone (operating-system-timezone os) #:sudoers (operating-system-sudoers os) @@ -339,6 +336,25 @@ alias ll='ls -l' "root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n") +(define (user-group->gexp group) + "Turn GROUP, a object, into a list-valued gexp suitable for +'active-groups'." + #~(list #$(user-group-name group) + #$(user-group-password group) + #$(user-group-id group))) + +(define (user-account->gexp account) + "Turn ACCOUNT, a object, into a list-valued gexp suitable for +'activate-users'." + #~`(#$(user-account-name account) + #$(user-account-uid account) + #$(user-account-group account) + #$(user-account-supplementary-groups account) + #$(user-account-comment account) + #$(user-account-home-directory account) + ,#$(user-account-shell account) ; this one is a gexp + #$(user-account-password account))) + (define (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root." @@ -346,15 +362,25 @@ we're running in the final root." '((guix build activation) (guix build utils))) - (mlet* %store-monad - ((services (operating-system-services os)) - (etc (operating-system-etc-directory os)) - (modules (imported-modules %modules)) - (compiled (compiled-modules %modules)) - (dmd-conf (dmd-configuration-file services))) + (mlet* %store-monad ((services (operating-system-services os)) + (etc (operating-system-etc-directory os)) + (modules (imported-modules %modules)) + (compiled (compiled-modules %modules)) + (dmd-conf (dmd-configuration-file services)) + (accounts (operating-system-accounts os))) (define setuid-progs (operating-system-setuid-programs os)) + (define user-specs + (map user-account->gexp accounts)) + + (define groups + (append (operating-system-groups os) + (append-map service-user-groups services))) + + (define group-specs + (map user-group->gexp groups)) + (gexp->file "boot" #~(begin (eval-when (expand load eval) @@ -368,6 +394,13 @@ we're running in the final root." ;; Populate /etc. (activate-etc #$etc) + ;; Add users and user groups. + (setenv "PATH" + (string-append #$(@ (gnu packages admin) shadow) + "/sbin")) + (activate-users+groups (list #$@user-specs) + (list #$@group-specs)) + ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm index 3a43eb45e3..5440f5852f 100644 --- a/gnu/system/linux.scm +++ b/gnu/system/linux.scm @@ -154,11 +154,13 @@ should be the name of a file used as the message-of-the-day." (define* (base-pam-services #:key allow-empty-passwords?) "Return the list of basic PAM services everyone would want." - (list %pam-other-services - (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?) - (unix-pam-service "passwd" - #:allow-empty-passwords? allow-empty-passwords?) - (unix-pam-service "sudo" - #:allow-empty-passwords? allow-empty-passwords?))) + (cons %pam-other-services + (map (cut unix-pam-service <> + #:allow-empty-passwords? allow-empty-passwords?) + '("su" "passwd" "sudo" + "useradd" "userdel" "usermod" + "groupadd" "groupdel" "groupmod" + ;; TODO: Add other Shadow programs? + )))) ;;; linux.scm ends here diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 52242ee4e0..8745ddb876 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -30,9 +30,10 @@ #:export (user-account user-account? user-account-name - user-account-pass + user-account-password user-account-uid - user-account-gid + user-account-group + user-account-supplementary-groups user-account-comment user-account-home-directory user-account-shell @@ -42,11 +43,7 @@ user-group-name user-group-password user-group-id - user-group-members - - passwd-file - group-file - guix-build-accounts)) + user-group-members)) ;;; Commentary: ;;; @@ -58,9 +55,11 @@ user-account make-user-account user-account? (name user-account-name) - (password user-account-pass (default "")) - (uid user-account-uid) - (gid user-account-gid) + (password user-account-password (default #f)) + (uid user-account-uid (default #f)) + (group user-account-group) ; number | string + (supplementary-groups user-account-supplementary-groups + (default '())) ; list of strings (comment user-account-comment (default "")) (home-directory user-account-home-directory) (shell user-account-shell ; gexp @@ -71,47 +70,7 @@ user-group? (name user-group-name) (password user-group-password (default #f)) - (id user-group-id) + (id user-group-id (default #f)) (members user-group-members (default '()))) -(define (group-file groups) - "Return a /etc/group file for GROUPS, a list of objects." - (define contents - (let loop ((groups groups) - (result '())) - (match groups - ((($ name _ gid (users ...)) rest ...) - ;; XXX: Ignore the group password. - (loop rest - (cons (string-append name "::" (number->string gid) - ":" (string-join users ",")) - result))) - (() - (string-join (reverse result) "\n" 'suffix))))) - - (text-file "group" contents)) - -(define* (passwd-file accounts #:key shadow?) - "Return a password file for ACCOUNTS, a list of objects. 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 account-exp - (match-lambda - (($ name pass uid gid comment home-dir shell) - (if shadow? ; XXX: use (crypt PASS …)? - #~(format #t "~a::::::::~%" #$name) - #~(format #t "~a:x:~a:~a:~a:~a:~a~%" - #$name #$(number->string uid) #$(number->string gid) - #$comment #$home-dir #$shell))))) - - (define builder - #~(begin - (with-output-to-file #$output - (lambda () - #$@(map account-exp accounts) - #t)))) - - (gexp->derivation (if shadow? "shadow" "passwd") builder)) - ;;; shadow.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2520853205..ede7ea7726 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -267,16 +267,6 @@ such as /etc files." (define (operating-system-default-contents os) "Return a list of directives suitable for 'system-qemu-image' describing the basic contents of the root file system of OS." - (define (user-directories user) - (let ((home (user-account-home-directory user)) - ;; XXX: Deal with automatically allocated ids. - (uid (or (user-account-uid user) 0)) - (gid (or (user-account-gid user) 0)) - (root (string-append "/var/guix/profiles/per-user/" - (user-account-name user)))) - #~((directory #$root #$uid #$gid) - (directory #$home #$uid #$gid)))) - (mlet* %store-monad ((os-drv (operating-system-derivation os)) (build-gid (operating-system-build-gid os)) (profile (operating-system-profile os))) @@ -293,9 +283,8 @@ basic contents of the root file system of OS." (directory "/tmp") (directory "/var/guix/profiles/per-user/root" 0 0) - (directory "/root" 0 0) ; an exception - #$@(append-map user-directories - (operating-system-users os)))))) + (directory "/root" 0 0) ; an exception + (directory "/home" 0 0))))) (define* (system-qemu-image os #:key diff --git a/guix/build/activation.scm b/guix/build/activation.scm index f9d9ba5cbd..895f2bca5b 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -19,8 +19,11 @@ (define-module (guix build activation) #:use-module (guix build utils) #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (activate-etc + #:export (activate-users+groups + activate-etc activate-setuid-programs)) ;;; Commentary: @@ -31,6 +34,98 @@ ;;; ;;; Code: +(define* (add-group name #:key gid password + (log-port (current-error-port))) + "Add NAME as a user group, with the given numeric GID if specified." + ;; Use 'groupadd' from the Shadow package. + (format log-port "adding group '~a'...~%" name) + (let ((args `(,@(if gid `("-g" ,(number->string gid)) '()) + ,@(if password `("-p" ,password) '()) + ,name))) + (zero? (apply system* "groupadd" args)))) + +(define* (add-user name group + #:key uid comment home shell password + (supplementary-groups '()) + (log-port (current-error-port))) + "Create an account for user NAME part of GROUP, with the specified +properties. Return #t on success." + (format log-port "adding user '~a'...~%" name) + + (if (and uid (zero? uid)) + + ;; 'useradd' fails with "Cannot determine your user name" if the root + ;; account doesn't exist. Thus, for bootstrapping purposes, create that + ;; one manually. + (begin + (call-with-output-file "/etc/shadow" + (cut format <> "~a::::::::~%" name)) + (call-with-output-file "/etc/passwd" + (cut format <> "~a:x:~a:~a:~a:~a:~a~%" + name "0" "0" comment home shell)) + (chmod "/etc/shadow" #o600) + #t) + + ;; Use 'useradd' 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) '()) + ,@(if home `("-d" ,home "--create-home") '()) + ,@(if shell `("-s" ,shell) '()) + ,@(if password `("-p" ,password) '()) + ,name))) + (zero? (apply system* "useradd" args))))) + +(define (activate-users+groups users groups) + "Make sure the accounts listed in USERS and the user groups listed in GROUPS +are all available. + +Each item in USERS is a list of all the characteristics of a user account; +each item in GROUPS is a tuple with the group name, group password or #f, and +numeric gid or #f." + (define (touch file) + (call-with-output-file file (const #t))) + + (define activate-user + (match-lambda + ((name uid group supplementary-groups comment home shell password) + (unless (false-if-exception (getpwnam name)) + (let ((profile-dir (string-append "/var/guix/profiles/per-user/" + name))) + (add-user name group + #:uid uid + #:supplementary-groups supplementary-groups + #:comment comment + #:home home + #:shell shell + #:password password) + + ;; 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") + + ;; Create the root account so we can use 'useradd' and 'groupadd'. + (activate-user (find (match-lambda + ((name (? zero?) _ ...) #t) + (_ #f)) + users)) + + ;; Then create the groups. + (for-each (match-lambda + ((name password gid) + (add-group name #:gid gid #:password password))) + groups) + + ;; Finally create the other user accounts. + (for-each activate-user users)) + (define (activate-etc etc) "Install ETC, a directory in the store, as the source of static files for /etc." -- cgit v1.2.3 From f5ea273a001736af3e61207b094556893aa05309 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Mon, 12 May 2014 11:42:53 -0500 Subject: gnu: perl-tk: Patch for i686 * gnu/packages/patches/perl-tk-x11-discover.patch: New patch. * gnu-system.am [dist_patch_DATA]: Add it. * gnu/packages/tcl.scm (perl-tk)[origin]: Use it. --- gnu-system.am | 1 + gnu/packages/patches/perl-tk-x11-discover.patch | 14 ++++++++++++++ gnu/packages/tcl.scm | 4 +++- 3 files changed, 18 insertions(+), 1 deletion(-) create mode 100644 gnu/packages/patches/perl-tk-x11-discover.patch diff --git a/gnu-system.am b/gnu-system.am index fa8f6f7ec5..eb58cc60be 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -325,6 +325,7 @@ dist_patch_DATA = \ gnu/packages/patches/patchelf-page-size.patch \ gnu/packages/patches/patchutils-xfail-gendiff-tests.patch \ gnu/packages/patches/perl-no-sys-dirs.patch \ + gnu/packages/patches/perl-tk-x11-discover.patch \ gnu/packages/patches/petsc-fix-threadcomm.patch \ gnu/packages/patches/plotutils-libpng-jmpbuf.patch \ gnu/packages/patches/procps-make-3.82.patch \ diff --git a/gnu/packages/patches/perl-tk-x11-discover.patch b/gnu/packages/patches/perl-tk-x11-discover.patch new file mode 100644 index 0000000000..f4365e6882 --- /dev/null +++ b/gnu/packages/patches/perl-tk-x11-discover.patch @@ -0,0 +1,14 @@ +On non-x86_64 systems, this conditional can cause a specified X11 build value +to be overwritten to null, causing x11 discovery to fail. + +--- a/myConfig 2014-05-12 11:16:48.152719722 -0500 ++++ b/myConfig 2014-05-12 11:16:24.704719113 -0500 +@@ -350,7 +350,7 @@ + # + # Prefer 64bit libraries on certain architectures + # +- unless (defined $xlib and $Config{'archname'} =~ m/x86_64/) ++ unless (defined $xlib or not $Config{'archname'} =~ m/x86_64/) + { + $xlib64 = &lX11(0, chooseX11()); + } diff --git a/gnu/packages/tcl.scm b/gnu/packages/tcl.scm index eb4c227049..4859c2be72 100644 --- a/gnu/packages/tcl.scm +++ b/gnu/packages/tcl.scm @@ -23,6 +23,7 @@ #:use-module (guix download) #:use-module (guix build-system gnu) #:use-module (guix build-system perl) + #:use-module (gnu packages) #:use-module (gnu packages libpng) #:use-module (gnu packages libjpeg) #:use-module (gnu packages perl) @@ -177,7 +178,8 @@ X11 GUIs.") version ".tar.gz")) (sha256 (base32 - "0jarvplhfvnm0shhdm2a5zczlnk9mkf8jvfjiwyhjrr3cy1gl0w0")))) + "0jarvplhfvnm0shhdm2a5zczlnk9mkf8jvfjiwyhjrr3cy1gl0w0")) + (patches (list (search-patch "perl-tk-x11-discover.patch"))))) (build-system perl-build-system) (native-inputs `(("pkg-config" ,pkg-config))) (inputs `(("libx11" ,libx11) -- cgit v1.2.3 From a12d92f54efcd941c6e27c389235c7a98b174437 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 12 May 2014 21:40:16 +0200 Subject: doc: Add example for --search. * doc/guix.texi (Invoking guix package): Add LGPLv3 example. --- doc/guix.texi | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 82e713c0c9..98bf06636b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -828,6 +828,17 @@ name: libgc version: 7.2alpha6 @end example +Similarly, to show the name of all the packages available under the +terms of the GNU@tie{}LGPL version 3: + +@example +$ guix package -s "" | recsel -p name -e 'license ~ "LGPL 3"' +name: elfutils + +name: gmp +@dots{} +@end example + @item --list-installed[=@var{regexp}] @itemx -I [@var{regexp}] List the currently installed packages in the specified profile, with the -- cgit v1.2.3 From 40281c542490e56abea648b3405dd133c549469d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 12 May 2014 23:37:13 +0200 Subject: system: Populate /etc/skel. * gnu/system.scm ()[skeletons]: New field. (default-skeletons, skeleton-directory): New procedures. (etc-directory): Add #:skeletons parameter. Call 'skeleton-directory', and produce the 'skel' sub-directory. (operating-system-etc-directory): Pass #:skeletons to 'etc-directory'. --- gnu/system.scm | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 61 insertions(+), 2 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index bd69532a89..ce5aad22bb 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -26,6 +26,7 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages admin) + #:use-module (gnu packages guile-wm) #:use-module (gnu packages package-management) #:use-module (gnu services) #:use-module (gnu services dmd) @@ -98,6 +99,9 @@ (name "root") (id 0))))) + (skeletons operating-system-skeletons ; list of name/monadic value + (default (default-skeletons))) + (packages operating-system-packages ; list of (PACKAGE OUTPUT...) (default (list coreutils ; or just PACKAGE grep @@ -184,6 +188,11 @@ file." (gexp->derivation name builder)) + +;;; +;;; Services. +;;; + (define (other-file-system-services os) "Return file system services for the file systems of OS that are not marked as 'needed-for-boot'." @@ -222,8 +231,54 @@ explicitly appear in OS." (essential (essential-services os))) (return (append essential user)))) + +;;; +;;; /etc. +;;; + +(define (default-skeletons) + "Return the default skeleton files for /etc/skel. These files are copied by +'useradd' in the home directory of newly created user accounts." + (define copy-guile-wm + #~(begin + (use-modules (guix build utils)) + (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) + #$output))) + + (mlet %store-monad ((bashrc (text-file "bashrc" "\ +# Allow non-login shells such as an xterm to get things right. +test -f /etc/profile && source /etc/profile\n")) + (guile-wm (gexp->derivation "guile-wm" copy-guile-wm + #:modules + '((guix build utils)))) + (xdefaults (text-file "Xdefaults" "\ +XTerm*utf8: always +XTerm*metaSendsEscape: true\n"))) + (return `((".bashrc" ,bashrc) + (".Xdefaults" ,xdefaults) + (".guile-wm" ,guile-wm))))) + +(define (skeleton-directory skeletons) + "Return a directory containing SKELETONS, a list of name/derivation pairs." + (gexp->derivation "skel" + #~(begin + (use-modules (ice-9 match)) + + (mkdir #$output) + (chdir #$output) + + ;; Note: copy the skeletons instead of symlinking + ;; them like 'file-union' does, because 'useradd' + ;; would just copy the symlinks as is. + (for-each (match-lambda + ((target source) + (copy-file source target))) + '#$skeletons) + #t))) + (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") + (skeletons '()) (pam-services '()) (profile "/var/run/current-system/profile") (sudoers "")) @@ -261,7 +316,8 @@ export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' alias ll='ls -l' -"))) +")) + (skel (skeleton-directory skeletons))) (file-union "etc" `(("services" ,#~(string-append #$net-base "/etc/services")) ("protocols" ,#~(string-append #$net-base "/etc/protocols")) @@ -269,6 +325,7 @@ alias ll='ls -l' ("pam.d" ,#~#$pam.d) ("login.defs" ,#~#$login.defs) ("issue" ,#~#$issue) + ("skel" ,#~#$skel) ("shells" ,#~#$shells) ("profile" ,#~#$bashrc) ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" @@ -313,8 +370,10 @@ alias ll='ls -l' (delete-duplicates (append (operating-system-pam-services os) (append-map service-pam-services services)))) - (profile-drv (operating-system-profile os))) + (profile-drv (operating-system-profile os)) + (skeletons (operating-system-skeletons os))) (etc-directory #:pam-services pam-services + #:skeletons skeletons #:locale (operating-system-locale os) #:timezone (operating-system-timezone os) #:sudoers (operating-system-sudoers os) -- cgit v1.2.3 From a37b807769cb5505384acd17d3f042398471f079 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 12 May 2014 23:54:30 +0200 Subject: gnu: Add babl. * gnu/packages/gimp.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. --- gnu-system.am | 1 + gnu/packages/gimp.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 64 insertions(+) create mode 100644 gnu/packages/gimp.scm diff --git a/gnu-system.am b/gnu-system.am index eb58cc60be..b54aba1ab7 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -85,6 +85,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/gettext.scm \ gnu/packages/ghostscript.scm \ gnu/packages/giflib.scm \ + gnu/packages/gimp.scm \ gnu/packages/gkrellm.scm \ gnu/packages/gl.scm \ gnu/packages/glib.scm \ diff --git a/gnu/packages/gimp.scm b/gnu/packages/gimp.scm new file mode 100644 index 0000000000..bdcd46f38e --- /dev/null +++ b/gnu/packages/gimp.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu packages gimp) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module ((guix licenses) + #:renamer (symbol-prefix-proc 'license:)) + #:use-module (guix build-system gnu) + #:use-module (gnu packages pkg-config) + #:use-module (gnu packages glib) + #:use-module (gnu packages gtk) + #:use-module (gnu packages gnome) + #:use-module (gnu packages libpng) + #:use-module (gnu packages libjpeg) + #:use-module ((gnu packages ghostscript) + #:select (lcms)) + #:use-module (gnu packages compression) + #:use-module (gnu packages xml) + #:use-module (gnu packages photo) + #:use-module (gnu packages xorg) + #:use-module (gnu packages imagemagick)) + +(define-public babl + (package + (name "babl") + (version "0.1.10") + (source (origin + (method url-fetch) + (uri (list (string-append "http://ftp.gtk.org/pub/babl/0.1/babl-" + version ".tar.bz2") + (string-append "ftp://ftp.gtk.org/pub/babl/0.1/babl-" + version ".tar.bz2"))) + (sha256 + (base32 + "1x2mb7zfbvk9d0a7h5cpdff9hhjsadxvqml2jay2bpf7x9nc6gwl")))) + (build-system gnu-build-system) + (home-page "http://gegl.org/babl/") + (synopsis "Image pixel format conversion library") + (description + "babl is a dynamic, any to any, pixel format translation library. +It allows converting between different methods of storing pixels known as +pixel formats that have with different bitdepths and other data +representations, color models and component permutations. + +A vocabulary to formulate new pixel formats from existing primitives is +provided as well as the framework to add new color models and data types.") + (license license:lgpl3+))) -- cgit v1.2.3 From 5b527256ee8d280ec6f5d445522beb120005ad84 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Mon, 12 May 2014 16:43:04 -0500 Subject: gnu: openmpi: Use our hwloc. * gnu/packages/mpi.scm (hwloc): Propagate numactl. (openmpi)[inputs]: Add hwloc. [native-inputs]: Add pkg-config. [argument]: Add hwloc configure flags. --- gnu/packages/mpi.scm | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/gnu/packages/mpi.scm b/gnu/packages/mpi.scm index 071229214b..37b7858469 100644 --- a/gnu/packages/mpi.scm +++ b/gnu/packages/mpi.scm @@ -51,16 +51,16 @@ ;; Enable libpci support, which effectively makes hwloc GPLv2+. '(#:configure-flags '("--enable-libpci"))) (inputs - `(("numactl" ,numactl) - ("libx11" ,libx11) + `(("libx11" ,libx11) ("cairo" ,cairo) ("ncurses" ,ncurses) ("expat" ,expat))) (native-inputs `(("pkg-config" ,pkg-config))) (propagated-inputs - ;; 'hwloc.pc' refers to libpci, hence the propagation. - `(("pciutils" ,pciutils))) + ;; 'hwloc.pc' refers to libpci and libnuma, hence the propagation. + `(("numactl" ,numactl) + ("pciutils" ,pciutils))) (home-page "http://www.open-mpi.org/projects/hwloc/") (synopsis "Abstraction of hardware architectures") (description @@ -94,11 +94,14 @@ bind processes, and much more.") (base32 "13z1q69f3qwmmhpglarfjminfy2yw4rfqr9jydjk5507q3mjf50p")))) (build-system gnu-build-system) - ;; TODO: Use our hwloc instead of the bundled one. + (inputs + `(("hwloc" ,hwloc))) + (native-inputs + `(("pkg-config" ,pkg-config))) (propagated-inputs `(("gfortran" ,gfortran-4.8))) (arguments - `(#:configure-flags '("--enable-static" + `(#:configure-flags `("--enable-static" "--enable-oshmem" ;; Thread support causes some applications to hang ;; "--enable-event-thread-support" @@ -106,7 +109,9 @@ bind processes, and much more.") ;; "--enable-orte-progress-threads" ;; "--enable-mpi-thread-multiple" "--enable-mpi-ext=all" - "--with-devel-headers"))) + "--with-devel-headers" + ,(string-append "--with-hwloc=" + (assoc-ref %build-inputs "hwloc"))))) (home-page "http://www.open-mpi.org") (synopsis "MPI-2 implementation") (description -- cgit v1.2.3 From 1a389e8d21b375d5de0a220faf42199ae6102333 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 May 2014 19:04:27 +0200 Subject: system: Add skeleton '.gdbinit'. * gnu/system.scm (default-skeletons): Add .gdbinit. --- gnu/system.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index ce5aad22bb..fae8fe44a1 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -253,10 +253,14 @@ test -f /etc/profile && source /etc/profile\n")) '((guix build utils)))) (xdefaults (text-file "Xdefaults" "\ XTerm*utf8: always -XTerm*metaSendsEscape: true\n"))) +XTerm*metaSendsEscape: true\n")) + (gdbinit (text-file "gdbinit" "\ +# Tell GDB where to look for separate debugging files. +set debug-file-directory ~/.guix-profile/lib/debug\n"))) (return `((".bashrc" ,bashrc) (".Xdefaults" ,xdefaults) - (".guile-wm" ,guile-wm))))) + (".guile-wm" ,guile-wm) + (".gdbinit" ,gdbinit))))) (define (skeleton-directory skeletons) "Return a directory containing SKELETONS, a list of name/derivation pairs." -- cgit v1.2.3 From 64d76fa6c2b7ded4f18874f413168c26dd5af803 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 May 2014 21:22:38 +0200 Subject: doc: Improve debugging file documentation. * doc/guix.texi (Installing Debugging Files): Add @cindex. Remove unneeded '-i' in example. Mention source code an 'directory'. Link to "Build Systems" instead of "Defining Packages". --- doc/guix.texi | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 98bf06636b..770e7ab062 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2604,6 +2604,7 @@ to join! @ref{Contributing}, for information about how you can help. @node Installing Debugging Files @section Installing Debugging Files +@cindex debugging files Program binaries, as produced by the GCC compilers for instance, are typically written in the ELF format, with a section containing @dfn{debugging information}. Debugging information is what allows the @@ -2634,7 +2635,7 @@ installs the debugging information for the GNU C Library and for GNU Guile: @example -guix package -i glibc:debug -i guile:debug +guix package -i glibc:debug guile:debug @end example GDB must then be told to look for debug files in the user's profile, by @@ -2649,9 +2650,16 @@ GDB}): From there on, GDB will pick up debugging information from the @code{.debug} files under @file{~/.guix-profile/lib/debug}. +In addition, you will most likely want GDB to be able to show the source +code being debugged. To do that, you will have to unpack the source +code of the package of interest (obtained with @code{guix build +--source}, @pxref{Invoking guix build}), and to point GDB to that source +directory using the @code{directory} command (@pxref{Source Path, +@code{directory},, gdb, Debugging with GDB}). + @c XXX: keep me up-to-date The @code{debug} output mechanism in Guix is implemented by the -@code{gnu-build-system} (@pxref{Defining Packages}). Currently, it is +@code{gnu-build-system} (@pxref{Build Systems}). Currently, it is opt-in---debugging information is available only for those packages whose definition explicitly declares a @code{debug} output. This may be changed to opt-out in the future, if our build farm servers can handle -- cgit v1.2.3 From 838d9a9ddb3186e587adfa7329c7e577d766001d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 May 2014 21:32:48 +0200 Subject: system: Move skeleton code to (gnu system shadow). * gnu/system.scm (default-skeletons, skeleton-directory): Move to... * gnu/system/shadow.scm: ... here. --- gnu/system.scm | 45 ------------------------------------------ gnu/system/shadow.scm | 54 ++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 49 insertions(+), 50 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index fae8fe44a1..f78df7ce19 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -26,7 +26,6 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages admin) - #:use-module (gnu packages guile-wm) #:use-module (gnu packages package-management) #:use-module (gnu services) #:use-module (gnu services dmd) @@ -236,50 +235,6 @@ explicitly appear in OS." ;;; /etc. ;;; -(define (default-skeletons) - "Return the default skeleton files for /etc/skel. These files are copied by -'useradd' in the home directory of newly created user accounts." - (define copy-guile-wm - #~(begin - (use-modules (guix build utils)) - (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) - #$output))) - - (mlet %store-monad ((bashrc (text-file "bashrc" "\ -# Allow non-login shells such as an xterm to get things right. -test -f /etc/profile && source /etc/profile\n")) - (guile-wm (gexp->derivation "guile-wm" copy-guile-wm - #:modules - '((guix build utils)))) - (xdefaults (text-file "Xdefaults" "\ -XTerm*utf8: always -XTerm*metaSendsEscape: true\n")) - (gdbinit (text-file "gdbinit" "\ -# Tell GDB where to look for separate debugging files. -set debug-file-directory ~/.guix-profile/lib/debug\n"))) - (return `((".bashrc" ,bashrc) - (".Xdefaults" ,xdefaults) - (".guile-wm" ,guile-wm) - (".gdbinit" ,gdbinit))))) - -(define (skeleton-directory skeletons) - "Return a directory containing SKELETONS, a list of name/derivation pairs." - (gexp->derivation "skel" - #~(begin - (use-modules (ice-9 match)) - - (mkdir #$output) - (chdir #$output) - - ;; Note: copy the skeletons instead of symlinking - ;; them like 'file-union' does, because 'useradd' - ;; would just copy the symlinks as is. - (for-each (match-lambda - ((target source) - (copy-file source target))) - '#$skeletons) - #t))) - (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") (skeletons '()) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 8745ddb876..738816b78f 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -17,16 +17,13 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu system shadow) - #:use-module (guix store) #:use-module (guix records) - #:use-module (guix packages) #:use-module (guix gexp) #:use-module (guix monads) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) - #:use-module (srfi srfi-1) - #:use-module (ice-9 match) + #:use-module (gnu packages guile-wm) #:export (user-account user-account? user-account-name @@ -43,7 +40,10 @@ user-group-name user-group-password user-group-id - user-group-members)) + user-group-members + + default-skeletons + skeleton-directory)) ;;; Commentary: ;;; @@ -73,4 +73,48 @@ (id user-group-id (default #f)) (members user-group-members (default '()))) +(define (default-skeletons) + "Return the default skeleton files for /etc/skel. These files are copied by +'useradd' in the home directory of newly created user accounts." + (define copy-guile-wm + #~(begin + (use-modules (guix build utils)) + (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) + #$output))) + + (mlet %store-monad ((bashrc (text-file "bashrc" "\ +# Allow non-login shells such as an xterm to get things right. +test -f /etc/profile && source /etc/profile\n")) + (guile-wm (gexp->derivation "guile-wm" copy-guile-wm + #:modules + '((guix build utils)))) + (xdefaults (text-file "Xdefaults" "\ +XTerm*utf8: always +XTerm*metaSendsEscape: true\n")) + (gdbinit (text-file "gdbinit" "\ +# Tell GDB where to look for separate debugging files. +set debug-file-directory ~/.guix-profile/lib/debug\n"))) + (return `((".bashrc" ,bashrc) + (".Xdefaults" ,xdefaults) + (".guile-wm" ,guile-wm) + (".gdbinit" ,gdbinit))))) + +(define (skeleton-directory skeletons) + "Return a directory containing SKELETONS, a list of name/derivation pairs." + (gexp->derivation "skel" + #~(begin + (use-modules (ice-9 match)) + + (mkdir #$output) + (chdir #$output) + + ;; Note: copy the skeletons instead of symlinking + ;; them like 'file-union' does, because 'useradd' + ;; would just copy the symlinks as is. + (for-each (match-lambda + ((target source) + (copy-file source target))) + '#$skeletons) + #t))) + ;;; shadow.scm ends here -- cgit v1.2.3 From 5a84a6c3146bd0ea8e5cbccfee2f6c9f302c25e0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 May 2014 23:56:24 +0200 Subject: vm: Pass '-serial stdio' in the run-vm.sh. * gnu/system/vm.scm (system-qemu-image/shared-store-script): Add '-serial stdio'. --- gnu/system/vm.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index ede7ea7726..c6c23213ca 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -365,6 +365,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") "--load=" #$os-drv "/boot --root=/dev/vda1\" \ + -serial stdio \ -drive file=" #$image ",if=virtio,cache=writeback,werror=report,readonly\n") port) -- cgit v1.2.3 From e7e5a4f8d4b67edd3c003b1ab36d6c42f7c4483b Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 14 May 2014 14:30:28 +0200 Subject: gnu: qt-4: Enable session management by adding libsm as an input. * gnu/packages/qt.scm (qt-4): Add input qt-4. --- gnu/packages/qt.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm index a47dcac50f..f813011eb5 100644 --- a/gnu/packages/qt.scm +++ b/gnu/packages/qt.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -163,7 +163,8 @@ developers using C++ or QML, a CSS & JavaScript like language.") "0f51dbgn1dcck8pqimls2qyf1pfmsmyknh767cvw87c3d218ywpb")) (patches (list (search-patch "qt4-tests.patch"))))) (inputs `(,@(alist-delete "libjpeg" (package-inputs qt)) - ("libjepg" ,libjpeg-8))) + ("libjepg" ,libjpeg-8) + ("libsm" ,libsm))) (arguments `(#:phases (alist-replace -- cgit v1.2.3 From c98f2ff309d481c034b61240f3432d76fd74eea5 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 14 May 2014 15:53:00 +0200 Subject: gnu: qt-4: Upgrade to 4.8.6. * gnu/packages/qt.scm (qt-4): Upgrade to 4.8.6. --- gnu/packages/qt.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm index f813011eb5..de8dbdea48 100644 --- a/gnu/packages/qt.scm +++ b/gnu/packages/qt.scm @@ -150,7 +150,7 @@ developers using C++ or QML, a CSS & JavaScript like language.") (define-public qt-4 (package (inherit qt) - (version "4.8.5") + (version "4.8.6") (source (origin (method url-fetch) (uri (string-append "http://download.qt-project.org/official_releases/qt/" @@ -160,7 +160,7 @@ developers using C++ or QML, a CSS & JavaScript like language.") version ".tar.gz")) (sha256 (base32 - "0f51dbgn1dcck8pqimls2qyf1pfmsmyknh767cvw87c3d218ywpb")) + "0b036iqgmbbv37dgwwfihw3mihjbnw3kb5kaisdy0qi8nn8xs54b")) (patches (list (search-patch "qt4-tests.patch"))))) (inputs `(,@(alist-delete "libjpeg" (package-inputs qt)) ("libjepg" ,libjpeg-8) -- cgit v1.2.3 From 211345b3a5097f9a6ed036c9a6a231ec9fa34ad8 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Wed, 14 May 2014 16:04:42 +0200 Subject: gnu: libsm: Propagate input libice. * gnu/packages/xorg.scm (libsm): Propagate input libice. --- gnu/packages/xorg.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm index cc9af18a74..8264c3a2ed 100644 --- a/gnu/packages/xorg.scm +++ b/gnu/packages/xorg.scm @@ -1153,10 +1153,11 @@ tracking.") (base32 "07bzi6xwlhq36f60qfspjbz0qjj7zcgayi1vp4ihgx34kib1vhck")))) (build-system gnu-build-system) + (propagated-inputs + `(("libice" ,libice))) ; SMlib.h includes ICElib.h (inputs `(("xtrans" ,xtrans) - ("util-linux" ,util-linux) - ("libice" ,libice))) + ("util-linux" ,util-linux))) (native-inputs `(("pkg-config" ,pkg-config))) (home-page "http://www.x.org/wiki/") -- cgit v1.2.3 From 17a4d344899dca6a429fc79bc3b54edbe5079956 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:35:35 +0200 Subject: syscalls: Add 'processes' to list all the live processes. * guix/build/syscalls.scm (kernel?, processes): New procedures. --- guix/build/syscalls.scm | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 90cacc760b..7a1bad7331 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -22,13 +22,15 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) + #:use-module (ice-9 ftw) #:export (errno MS_RDONLY MS_REMOUNT MS_BIND MS_MOVE mount - umount)) + umount + processes)) ;;; Commentary: ;;; @@ -153,4 +155,29 @@ constants from ." (when update-mtab? (remove-from-mtab target)))))) +(define (kernel? pid) + "Return #t if PID designates a \"kernel thread\" rather than a normal +user-land process." + (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid) + (compose string-tokenize read-string)))) + ;; See proc.txt in Linux's documentation for the list of fields. + (match stat + ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt + cmin_flt maj_flt cmaj_flt utime stime cutime cstime + priority nice num_thread it_real_value start_time + vsize rss rsslim + (= string->number start_code) (= string->number end_code) _ ...) + ;; Got this obscure trick from sysvinit's 'killall5' program. + (and (zero? start_code) (zero? end_code)))))) + +(define (processes) + "Return the list of live processes." + (sort (filter-map (lambda (file) + (let ((pid (string->number file))) + (and pid + (not (kernel? pid)) + pid))) + (scandir "/proc")) + <)) + ;;; syscalls.scm ends here -- cgit v1.2.3 From 7d57cfd3b6625d7ab7f796b90b9606c28ec3aeef Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:38:21 +0200 Subject: system: When unionfs-fuse is used for /, don't kill it when halting. * guix/build/linux-initrd.scm (pidof): New procedure. (mount-root-file-system)[mark-as-not-killable]: New procedure. Use it for unionfs when VOLATILE-ROOT?. * gnu/services/base.scm (%do-not-kill-file): New variable. (user-processes-service)[stop]: Honor it. --- gnu/services/base.scm | 42 +++++++++++++++++++++++++++++++++++++++--- guix/build/linux-initrd.scm | 26 +++++++++++++++++++++++++- 2 files changed, 64 insertions(+), 4 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 1f5ff3e4cb..aec6050588 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -110,6 +110,11 @@ OPTIONS. When CHECK? is true, check the file system before mounting it." (umount #$target) #f)))))) +(define %do-not-kill-file + ;; Name of the file listing PIDs of processes that must survive when halting + ;; the system. Typical example is user-space file systems. + "/etc/dmd/do-not-kill") + (define* (user-processes-service requirements #:key (grace-delay 2)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before @@ -128,6 +133,25 @@ stopped before 'kill' is called." (requirement (cons 'root-file-system requirements)) (start #~(const #t)) (stop #~(lambda _ + (define (kill-except omit signal) + ;; Kill all the processes with SIGNAL except those + ;; listed in OMIT and the current process. + (let ((omit (cons (getpid) omit))) + (for-each (lambda (pid) + (unless (memv pid omit) + (false-if-exception + (kill pid signal)))) + (processes)))) + + (define omitted-pids + ;; List of PIDs that must not be killed. + (if (file-exists? #$%do-not-kill-file) + (map string->number + (call-with-input-file #$%do-not-kill-file + (compose string-tokenize + (@ (ice-9 rdelim) read-string)))) + '())) + ;; When this happens, all the processes have been ;; killed, including 'deco', so DMD-OUTPUT-PORT and ;; thus CURRENT-OUTPUT-PORT are dangling. @@ -136,9 +160,21 @@ stopped before 'kill' is called." (display "sending all processes the TERM signal\n" port))) - (kill -1 SIGTERM) - (sleep #$grace-delay) - (kill -1 SIGKILL) + (if (null? omitted-pids) + (begin + ;; Easy: terminate all of them. + (kill -1 SIGTERM) + (sleep #$grace-delay) + (kill -1 SIGKILL)) + (begin + ;; Kill them all except OMITTED-PIDS. XXX: We + ;; would like to (kill -1 SIGSTOP) to get a fixed + ;; list of processes, like 'killall5' does, but + ;; that seems unreliable. + (kill-except omitted-pids SIGTERM) + (sleep #$grace-delay) + (kill-except omitted-pids SIGKILL) + (delete-file #$%do-not-kill-file))) (display "all processes have been terminated\n") #f)) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 0c3b2f0d9f..b488668ee2 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -200,11 +200,30 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." the last argument of `mknod'." (+ (* major 256) minor)) +(define (pidof program) + "Return the PID of the first presumed instance of PROGRAM." + (let ((program (basename program))) + (find (lambda (pid) + (let ((exe (format #f "/proc/~a/exe" pid))) + (and=> (false-if-exception (readlink exe)) + (compose (cut string=? program <>) basename)))) + (filter-map string->number (scandir "/proc"))))) + (define* (mount-root-file-system root type #:key volatile-root? (unionfs "unionfs")) "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is true, mount ROOT read-only and make it a union with a writable tmpfs using UNIONFS." + (define (mark-as-not-killable pid) + ;; Tell the 'user-processes' dmd service that PID must be kept alive when + ;; shutting down. + (mkdir-p "/root/etc/dmd") + (let ((port (open-file "/root/etc/dmd/do-not-kill" "a"))) + (chmod port #o600) + (write pid port) + (newline port) + (close-port port))) + (catch #t (lambda () (if volatile-root? @@ -222,7 +241,12 @@ UNIONFS." "cow,allow_other,use_ino,suid,dev" "/rw-root=RW:/real-root=RO" "/root")) - (error "unionfs failed"))) + (error "unionfs failed")) + + ;; Make sure unionfs remains alive till the end. Because + ;; 'fuse_daemonize' doesn't tell the PID of the forked daemon, we + ;; have to resort to 'pidof' here. + (mark-as-not-killable (pidof unionfs))) (begin (check-file-system root type) (mount root "/root" type)))) -- cgit v1.2.3 From 7f17ff78419b6088cbc8cec6e5f567a317fba809 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 16:38:47 +0200 Subject: linux-initrd: Make /dev/ttyS0, for debugging. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make /dev/ttyS0. --- guix/build/linux-initrd.scm | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index b488668ee2..a89ff86bbb 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -124,6 +124,10 @@ (device-number 4 n)) (loop (+ 1 n))))) + ;; Serial line. + (mknod (scope "dev/ttyS0") 'char-special #o660 + (device-number 4 64)) + ;; Pseudo ttys. (mknod (scope "dev/ptmx") 'char-special #o666 (device-number 5 2)) -- cgit v1.2.3 From f3b692acdd6da6c6a660f3d1b8de79e7f6ca25c7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 19:05:21 +0200 Subject: activation: Silence warning from 'useradd'. * guix/build/activation.scm (add-user): Don't pass '--create-home' when HOME already exists. --- guix/build/activation.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 895f2bca5b..267c592b52 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -73,7 +73,11 @@ properties. Return #t on success." `("-G" ,(string-join supplementary-groups ",")) '()) ,@(if comment `("-c" ,comment) '()) - ,@(if home `("-d" ,home "--create-home") '()) + ,@(if home + (if (file-exists? home) + `("-d" ,home) ; avoid warning from 'useradd' + `("-d" ,home "--create-home")) + '()) ,@(if shell `("-s" ,shell) '()) ,@(if password `("-p" ,password) '()) ,name))) -- cgit v1.2.3 From 4106c589885bceab3faee9d446f348784018891c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 23:02:10 +0200 Subject: gnu: xterm: Upgrade to 304. * gnu/packages/xorg.scm (xterm): Upgrade to 304. Switch to a version-specific URL. --- gnu/packages/xorg.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm index 8264c3a2ed..a480896083 100644 --- a/gnu/packages/xorg.scm +++ b/gnu/packages/xorg.scm @@ -4735,14 +4735,14 @@ icccm: Both client and window-manager helpers for ICCCM.") (define-public xterm (package (name "xterm") - (version "303") + (version "304") (source (origin (method url-fetch) - (uri ; XXX: constant URL! - "http://invisible-island.net/datafiles/release/xterm.tar.gz") + (uri (string-append "ftp://ftp.invisible-island.net/xterm/" + "xterm-" version ".tgz")) (sha256 (base32 - "0n7hay16aam9kfn642ri0wj5yzilbjm3l8znxc2p5dx9pn3rkwla")))) + "19yp5phfzzgydc2yqka4p69ygvfzsd2aa98hbw086xyjlws3kbyk")))) (build-system gnu-build-system) (arguments '(#:configure-flags '("--enable-wide-chars" "--enable-256-color" -- cgit v1.2.3 From 1eeccc2f31c0b0f8c600cb181f19fda1d90551a6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 23:15:51 +0200 Subject: vm: Keep acceptable file systems from the original OS. * gnu/system/vm.scm (virtualized-operating-system): Instead of completely overriding 'file-systems', use 'remove' to filter out some of those declared in OS. (system-qemu-image): Likewise. --- gnu/system/vm.scm | 49 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 35 insertions(+), 14 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index c6c23213ca..f42feb394c 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -292,12 +292,23 @@ basic contents of the root file system of OS." (disk-image-size (* 900 (expt 2 20)))) "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes of the GNU system as described by OS." + (define file-systems-to-keep + ;; Keep only file systems other than root and not normally bound to real + ;; devices. + (remove (lambda (fs) + (let ((target (file-system-mount-point fs)) + (source (file-system-device fs))) + (or (string=? target "/") + (string-prefix? "/dev/" source)))) + (operating-system-file-systems os))) + (let ((os (operating-system (inherit os) - ;; The mounted file systems are under our control. - (file-systems (list (file-system + ;; Force our own root file system. + (file-systems (cons (file-system (mount-point "/") (device "/dev/sda1") - (type file-system-type))))))) + (type file-system-type)) + file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) (os-dir -> (derivation->output-path os-drv)) @@ -315,17 +326,27 @@ of the GNU system as described by OS." environment with the store shared with the host." (operating-system (inherit os) (initrd (cut qemu-initrd <> #:volatile-root? #t)) - (file-systems (list (file-system - (mount-point "/") - (device "/dev/vda1") - (type "ext4")) - (file-system - (mount-point (%store-prefix)) - (device "store") - (type "9p") - (needed-for-boot? #t) - (options "trans=virtio") - (check? #f)))))) + (file-systems (cons* (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + (file-system + (mount-point (%store-prefix)) + (device "store") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio") + (check? #f)) + + ;; Remove file systems that conflict with those + ;; above, or that are normally bound to real devices. + (remove (lambda (fs) + (let ((target (file-system-mount-point fs)) + (source (file-system-device fs))) + (or (string=? target (%store-prefix)) + (string=? target "/") + (string-prefix? "/dev/" source)))) + (operating-system-file-systems os)))))) (define* (system-qemu-image/shared-store os -- cgit v1.2.3 From 2717a89a84f9af72f1e0d32d96e192ea088a5124 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 May 2014 23:17:03 +0200 Subject: system: Provide declarations for the 'fusectl' and 'binfmt_misc' file systems. * gnu/system.scm (%fuse-control-file-system, %binary-format-file-system): New variables. * build-aux/hydra/demo-os.scm (file-systems): New field. --- build-aux/hydra/demo-os.scm | 5 +++++ gnu/system.scm | 26 +++++++++++++++++++++++++- 2 files changed, 30 insertions(+), 1 deletion(-) diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 4116c063f4..fd14bfc7e4 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -43,6 +43,11 @@ (host-name "gnu") (timezone "Europe/Paris") (locale "en_US.UTF-8") + (file-systems + ;; We don't provide a file system for /, but that's OK because the VM build + ;; code will automatically declare the / file system for us. + (list %fuse-control-file-system + %binary-format-file-system)) (users (list (user-account (name "guest") (group "wheel") diff --git a/gnu/system.scm b/gnu/system.scm index f78df7ce19..9ce94d0230 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -64,7 +64,10 @@ file-system-type file-system-needed-for-boot? file-system-flags - file-system-options)) + file-system-options + + %fuse-control-file-system + %binary-format-file-system)) ;;; Commentary: ;;; @@ -126,6 +129,11 @@ (sudoers operating-system-sudoers ; /etc/sudoers contents (default %sudoers-specification))) + +;;; +;;; File systems. +;;; + ;; File system declaration. (define-record-type* file-system make-file-system @@ -142,6 +150,22 @@ (check? file-system-check? ; Boolean (default #t))) +(define %fuse-control-file-system + ;; Control file system for Linux' file systems in user-space (FUSE). + (file-system + (device "fusectl") + (mount-point "/sys/fs/fuse/connections") + (type "fusectl") + (check? #f))) + +(define %binary-format-file-system + ;; Support for arbitrary executable binary format. + (file-system + (device "binfmt_misc") + (mount-point "/proc/sys/fs/binfmt_misc") + (type "binfmt_misc") + (check? #f))) + ;;; ;;; Derivation. -- cgit v1.2.3 From c336a66fe825e062052f0812cc729c5b04411117 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 May 2014 22:47:53 +0200 Subject: build: Remove fusectl from the default file systems in the demo OS. * build-aux/hydra/demo-os.scm (file-systems): Comment out %FUSE-CONTROL-FILE-SYSTEM, since fuse.ko is missing by default in the freestanding VM image. --- build-aux/hydra/demo-os.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index fd14bfc7e4..e36a9ca17d 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -46,7 +46,7 @@ (file-systems ;; We don't provide a file system for /, but that's OK because the VM build ;; code will automatically declare the / file system for us. - (list %fuse-control-file-system + (list ;; %fuse-control-file-system ; needs fuse.ko %binary-format-file-system)) (users (list (user-account (name "guest") -- cgit v1.2.3 From 150e20ddde726abdfe77fa666351738cccb06281 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 May 2014 22:55:14 +0200 Subject: vm: Support initialization of the store DB when the store is shared. * gnu/system/vm.scm (qemu-image): Rename #:inputs-to-copy to #:inputs, and #:initialize-store? to #:register-closures?. Add #:copy-inputs?. Adjust build gexp accordingly. (system-qemu-image): Remove #:initialize-store? argument and add #:copy-inputs?. (system-qemu-image/shared-store): Add #:inputs, #:register-closures?, and #:copy-inputs? arguments. * guix/build/vm.scm (register-closure): New procedure. (MS_BIND): New variable. (initialize-hard-disk): Rename #:initialize-store? to #:register-closures?, #:closures-to-copy to #:closures, and add #:copy-closures?. Add 'target-directory' and 'target-store' variables. Call 'populate-store' only when COPY-CLOSURES?. Bind-mount the store to TARGET-STORE when REGISTER-CLOSURES? and not COPY-CLOSURES?. Add call to 'register-closure'. --- gnu/system/vm.scm | 40 ++++++++++++++++++-------------- guix/build/vm.scm | 68 +++++++++++++++++++++++++++++++++++++++---------------- 2 files changed, 72 insertions(+), 36 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index f42feb394c..7008c5dab2 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,25 +192,26 @@ made available under the /xchg CIFS share." (disk-image-size (* 100 (expt 2 20))) (file-system-type "ext4") grub-configuration - (initialize-store? #f) + (register-closures? #t) (populate #f) - (inputs-to-copy '())) + (inputs '()) + copy-inputs?) "Return a bootable, stand-alone QEMU image, with a root partition of type FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) -INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied -into the image being built. When INITIALIZE-STORE? is true, initialize the -store database in the image so that Guix can be used in the image. +INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy +all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, +register INPUTS in the store database of the image so that Guix can be used in +the image. POPULATE is a list of directives stating directories or symlinks to be created in the disk image partition. It is evaluated once the image has been populated with INPUTS-TO-COPY. It can be used to provide additional files, such as /etc files." (mlet %store-monad - ((graph (sequence %store-monad - (map input->name+output inputs-to-copy)))) + ((graph (sequence %store-monad (map input->name+output inputs)))) (expression->derivation-in-linux-vm name #~(begin @@ -221,26 +222,27 @@ such as /etc files." '#$(append (list qemu parted grub e2fsprogs util-linux) (map (compose car (cut assoc-ref %final-inputs <>)) '("sed" "grep" "coreutils" "findutils" "gawk")) - (if initialize-store? (list guix) '()))) + (if register-closures? (list guix) '()))) ;; This variable is unused but allows us to add INPUTS-TO-COPY ;; as inputs. - (to-copy + (to-register '#$(map (match-lambda ((name thing) thing) ((name thing output) `(,thing ,output))) - inputs-to-copy))) + inputs))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (let ((graphs '#$(match inputs-to-copy + (let ((graphs '#$(match inputs (((names . _) ...) names)))) (initialize-hard-disk #:grub.cfg #$grub-configuration - #:closures-to-copy graphs + #:closures graphs + #:copy-closures? #$copy-inputs? + #:register-closures? #$register-closures? #:disk-image-size #$disk-image-size #:file-system-type #$file-system-type - #:initialize-store? #$initialize-store? #:directives '#$populate) (reboot)))) #:system system @@ -318,8 +320,8 @@ of the GNU system as described by OS." #:populate populate #:disk-image-size disk-image-size #:file-system-type file-system-type - #:initialize-store? #t - #:inputs-to-copy `(("system" ,os-drv)))))) + #:inputs `(("system" ,os-drv)) + #:copy-inputs? #t)))) (define (virtualized-operating-system os) "Return an operating system based on OS suitable for use in a virtualized @@ -358,10 +360,14 @@ with the host." (os-dir -> (derivation->output-path os-drv)) (grub.cfg -> (string-append os-dir "/grub.cfg")) (populate (operating-system-default-contents os))) - ;; TODO: Initialize the database so Guix can be used in the guest. (qemu-image #:grub-configuration grub.cfg #:populate populate - #:disk-image-size disk-image-size))) + #:disk-image-size disk-image-size + #:inputs `(("system" ,os-drv)) + + ;; XXX: Passing #t here is too slow, so let it off by default. + #:register-closures? #f + #:copy-inputs? #f))) (define* (system-qemu-image/shared-store-script os diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 1d1abad1dd..2c13a8904b 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -180,13 +180,36 @@ as created and modified at the Epoch." (utime file 0 0 0 0)))) (find-files directory ""))) +(define (register-closure store closure) + "Register CLOSURE in STORE, where STORE is the directory name of the target +store and CLOSURE is the name of a file containing a reference graph as used +by 'guix-register'." + (let ((status (system* "guix-register" "--prefix" store + closure))) + (unless (zero? status) + (error "failed to register store items" closure)))) + +(define MS_BIND 4096) ; again! + (define* (initialize-hard-disk #:key grub.cfg disk-image-size (file-system-type "ext4") - initialize-store? - (closures-to-copy '()) + (closures '()) + copy-closures? + (register-closures? #t) (directives '())) + "Initialize /dev/sda, a disk of DISK-IMAGE-SIZE bytes, with a +FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is +true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is +true, copy all of CLOSURES to the partition. Lastly, apply DIRECTIVES to +further populate the partition." + (define target-directory + "/fs") + + (define target-store + (string-append target-directory (%store-directory))) + (unless (initialize-partition-table "/dev/sda" #:partition-size (- disk-image-size (* 5 (expt 2 20)))) @@ -198,36 +221,43 @@ as created and modified at the Epoch." (error "failed to create partition")) (display "mounting partition...\n") - (mkdir "/fs") - (mount "/dev/sda1" "/fs" file-system-type) + (mkdir target-directory) + (mount "/dev/sda1" target-directory file-system-type) - (when (pair? closures-to-copy) + (when copy-closures? ;; Populate the store. - (populate-store (map (cut string-append "/xchg/" <>) - closures-to-copy) - "/fs")) + (populate-store (map (cut string-append "/xchg/" <>) closures) + target-directory)) ;; Populate /dev. - (make-essential-device-nodes #:root "/fs") + (make-essential-device-nodes #:root target-directory) ;; Optionally, register the inputs in the image's store. - (when initialize-store? + (when register-closures? + (unless copy-closures? + ;; XXX: 'guix-register' wants to palpate the things it registers, so + ;; bind-mount the store on the target. + (mkdir-p target-store) + (mount (%store-directory) target-store "" MS_BIND)) + + (display "registering closures...\n") (for-each (lambda (closure) - (let ((status (system* "guix-register" "--prefix" "/fs" - (string-append "/xchg/" closure)))) - (unless (zero? status) - (error "failed to register store items" closure)))) - closures-to-copy)) + (register-closure target-directory + (string-append "/xchg/" closure))) + closures) + (unless copy-closures? + (system* "umount" target-store))) ;; Evaluate the POPULATE directives. - (for-each (cut evaluate-populate-directive <> "/fs") + (display "populating...\n") + (for-each (cut evaluate-populate-directive <> target-directory) directives) - (unless (install-grub grub.cfg "/dev/sda" "/fs") + (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) - (reset-timestamps "/fs") + (reset-timestamps target-directory) - (zero? (system* "umount" "/fs"))) + (zero? (system* "umount" target-directory))) ;;; vm.scm ends here -- cgit v1.2.3 From 5ce3defed18c204989dceed64d3434ed9f3f1a92 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 May 2014 23:37:46 +0200 Subject: system: Add (guix build install) module. * guix/build/vm.scm (install-grub, evaluate-populate-directive, reset-timestamps, register-closure): Move to... * guix/build/install.scm: ... here. New file. * Makefile.am (MODULES): Add it. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add (guix build install) to #:modules. --- Makefile.am | 1 + gnu/system/vm.scm | 5 ++- guix/build/install.scm | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++ guix/build/vm.scm | 46 +--------------------------- 4 files changed, 86 insertions(+), 48 deletions(-) create mode 100644 guix/build/install.scm diff --git a/Makefile.am b/Makefile.am index 20bf650c9b..a08215ef1e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -70,6 +70,7 @@ MODULES = \ guix/build/rpath.scm \ guix/build/svn.scm \ guix/build/vm.scm \ + guix/build/install.scm \ guix/build/activation.scm \ guix/build/syscalls.scm \ guix/packages.scm \ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 7008c5dab2..58e5416b3e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -109,6 +109,7 @@ input tuple. The output file name is when building for SYSTEM." (env-vars '()) (modules '((guix build vm) + (guix build install) (guix build linux-initrd) (guix build utils))) (guile-for-build @@ -179,9 +180,7 @@ made available under the /xchg CIFS share." ;; TODO: Require the "kvm" feature. #:system system #:env-vars env-vars - #:modules `((guix build utils) - (guix build vm) - (guix build linux-initrd)) + #:modules modules #:guile-for-build guile-for-build #:references-graphs references-graphs))) diff --git a/guix/build/install.scm b/guix/build/install.scm new file mode 100644 index 0000000000..37153703e5 --- /dev/null +++ b/guix/build/install.scm @@ -0,0 +1,82 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix build install) + #:use-module (guix build utils) + #:use-module (guix build install) + #:use-module (ice-9 match) + #:export (install-grub + evaluate-populate-directive + reset-timestamps + register-closure)) + +;;; Commentary: +;;; +;;; This module supports the installation of the GNU system on a hard disk. +;;; It is meant to be used both in a build environment (in derivations that +;;; build VM images), and on the bare metal (when really installing the +;;; system.) +;;; +;;; Code: + +(define* (install-grub grub.cfg device mount-point) + "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on +MOUNT-POINT. Return #t on success." + (mkdir-p (string-append mount-point "/boot/grub")) + (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) + (zero? (system* "grub-install" "--no-floppy" + "--boot-directory" (string-append mount-point "/boot") + device))) + +(define (evaluate-populate-directive directive target) + "Evaluate DIRECTIVE, an sexp describing a file or directory to create under +directory TARGET." + (match directive + (('directory name) + (mkdir-p (string-append target name))) + (('directory name uid gid) + (let ((dir (string-append target name))) + (mkdir-p dir) + (chown dir uid gid))) + ((new '-> old) + (symlink old (string-append target new))))) + +(define (reset-timestamps directory) + "Reset the timestamps of all the files under DIRECTORY, so that they appear +as created and modified at the Epoch." + (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 /gnu/store, which is the host, + ;; read-only store. + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files directory ""))) + +(define (register-closure store closure) + "Register CLOSURE in STORE, where STORE is the directory name of the target +store and CLOSURE is the name of a file containing a reference graph as used +by 'guix-register'." + (let ((status (system* "guix-register" "--prefix" store + closure))) + (unless (zero? status) + (error "failed to register store items" closure)))) + +;;; install.scm ends here diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 2c13a8904b..12f952bd11 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -19,6 +19,7 @@ (define-module (guix build vm) #:use-module (guix build utils) #:use-module (guix build linux-initrd) + #:use-module (guix build install) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) @@ -124,15 +125,6 @@ partition of PARTITION-SIZE MiB. Return #t on success." "mkpart" "primary" "ext2" "1MiB" (format #f "~aB" partition-size)))) -(define* (install-grub grub.cfg device mount-point) - "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. Return #t on success." - (mkdir-p (string-append mount-point "/boot/grub")) - (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device))) - (define* (populate-store reference-graphs target) "Populate the store under directory TARGET with the items specified in REFERENCE-GRAPHS, a list of reference-graph files." @@ -153,42 +145,6 @@ REFERENCE-GRAPHS, a list of reference-graph files." (string-append target thing))) (things-to-copy))) -(define (evaluate-populate-directive directive target) - "Evaluate DIRECTIVE, an sexp describing a file or directory to create under -directory TARGET." - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - ((new '-> old) - (symlink old (string-append target new))))) - -(define (reset-timestamps directory) - "Reset the timestamps of all the files under DIRECTORY, so that they appear -as created and modified at the Epoch." - (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 /gnu/store, which is the host, - ;; read-only store. - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files directory ""))) - -(define (register-closure store closure) - "Register CLOSURE in STORE, where STORE is the directory name of the target -store and CLOSURE is the name of a file containing a reference graph as used -by 'guix-register'." - (let ((status (system* "guix-register" "--prefix" store - closure))) - (unless (zero? status) - (error "failed to register store items" closure)))) - (define MS_BIND 4096) ; again! (define* (initialize-hard-disk #:key -- cgit v1.2.3 From d0281fec03d93a44f7abaa270a3f7417b8e14627 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 10:20:45 +0200 Subject: list-runtime-roots: Don't display a backtrace on 2.0.5 when lsof is lacking. * nix/scripts/list-runtime-roots.in (lsof-roots): Fix typo in 'catch' tag. Add 'parent' variable. Wrap 'open-pipe*' call in 'catch'. Reported by Andreas Enge . --- nix/scripts/list-runtime-roots.in | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/nix/scripts/list-runtime-roots.in b/nix/scripts/list-runtime-roots.in index 4d329c5ff5..993eb169c1 100644 --- a/nix/scripts/list-runtime-roots.in +++ b/nix/scripts/list-runtime-roots.in @@ -1,7 +1,7 @@ #!@GUILE@ -ds !# ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -109,9 +109,27 @@ or the empty list." (define (lsof-roots) "Return the list of roots as found by calling `lsof'." - (catch 'system + (define parent (getpid)) + + (catch 'system-error (lambda () - (let ((pipe (open-pipe* OPEN_READ "lsof" "-n" "-w" "-F" "n"))) + (let ((pipe (catch 'system-error + (lambda () + (open-pipe* OPEN_READ "lsof" "-n" "-w" "-F" "n")) + (lambda args + ;; In Guile 2.0.5, when (ice-9 popen) was still written + ;; in Scheme, 'open-pipe*' would leave the child process + ;; behind it when 'execlp' failed (that was mostly + ;; harmless though, because the uncaught exception would + ;; cause it to terminate after printing a backtrace.) + ;; Make sure that doesn't happen. + (if (= (getpid) parent) + (apply throw args) + (begin + (format (current-error-port) + "failed to execute 'lsof': ~a~%" + (strerror (system-error-errno args))) + (primitive-exit 1))))))) (define %file-rx (make-regexp "^n/(.*)$")) -- cgit v1.2.3 From 4cca91832b3fceed35eb46439fac7c12466d229d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 10:22:19 +0200 Subject: authenticate: Add compatibility hack for Guile 2.0.5. * guix/scripts/authenticate.scm (%default-port-conversion-strategy): New variable. Reported by Andreas Enge . --- guix/scripts/authenticate.scm | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 1b1e0b08ca..e9900689fa 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -81,6 +81,13 @@ to stdout upon success." (canonical-sexp->string subject))) (leave (_ "error: corrupt signature data: ~a~%") (canonical-sexp->string signature))))) + +(define %default-port-conversion-strategy + ;; This fluid is in Guile > 2.0.5. + (if (defined? '%default-port-conversion-strategy) + (@ (guile) %default-port-conversion-strategy) + (make-fluid #f))) + ;;; ;;; Entry point with 'openssl'-compatible interface. We support this -- cgit v1.2.3 From 90f69c2ec598b7a94b7d35e4ce61bda245369b6d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 15:40:19 +0200 Subject: gnu: Add libuv. * gnu/packages/libevent.scm (libuv): New variable. --- gnu/packages/libevent.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 2 deletions(-) diff --git a/gnu/packages/libevent.scm b/gnu/packages/libevent.scm index dce1ac1a69..7b8adbace4 100644 --- a/gnu/packages/libevent.scm +++ b/gnu/packages/libevent.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +23,9 @@ #:use-module (guix download) #:use-module (guix build-system gnu) #:use-module (gnu packages which) - #:use-module (gnu packages python)) + #:use-module (gnu packages python) + #:use-module (gnu packages autotools) + #:use-module (gnu packages pkg-config)) (define-public libevent (package @@ -58,3 +60,44 @@ network servers. An application just needs to call event_dispatch() and then add or remove events dynamically without having to change the event loop.") (license bsd-3))) + +(define-public libuv + (package + (name "libuv") + (version "0.11.25") + (source (origin + (method url-fetch) + (uri (string-append "https://github.com/joyent/libuv/archive/v" + version ".tar.gz")) + (sha256 + (base32 + "1ys2wlypdbv59yywn91d5vl329z50mi7ivi3fj5rjm4mr9g3wnmr")))) + (build-system gnu-build-system) + (arguments + '(#:phases (alist-cons-before + 'configure 'autogen + (lambda _ + ;; Fashionable people don't run 'make dist' these days, so + ;; we need to do that ourselves. + (zero? (system* "./autogen.sh"))) + %standard-phases) + + ;; XXX: Some tests want /dev/tty, attempt to make connections, etc. + #:tests? #f)) + (native-inputs `(("autoconf" ,(autoconf-wrapper)) + ("automake" ,automake) + ("libtool" ,libtool "bin") + + ;; libuv.pc is installed only when pkg-config is found. + ("pkg-config" ,pkg-config))) + (home-page "https://github.com/joyent/libuv") + (synopsis "Library for asynchronous I/O") + (description + "libuv is a multi-platform support library with a focus on asynchronous +I/O. Among other things, it supports event loops via epoll, kqueue, and +similar IOCP, and event ports, asynchronous TCP/UDP sockets, asynchronous DNS +resolution, asynchronous file system operations, and threading primitives.") + + ;; A few files fall under other non-copyleft licenses; see 'LICENSE' for + ;; details. + (license x11))) -- cgit v1.2.3 From 7889394e059a2362d3227fb02256de4afd46129c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 21:56:00 +0200 Subject: guix system: Add 'build' action. * guix/scripts/system.scm (show-help): Document 'build' action. (guix-system): Honor 'build' action. * doc/guix.texi (Invoking guix system): Add 'build' action. --- doc/guix.texi | 5 +++++ guix/scripts/system.scm | 19 +++++++++++++------ 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 770e7ab062..4881ec6e1b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3204,6 +3204,11 @@ operating system is instantiate. Currently the following values are supported: @table @code +@item build +Build the operating system's derivation, which includes all the +configuration files and programs needed to boot and run the system. +This action does not actually install anything. + @item vm @cindex virtual machine Build a virtual machine that contain the operating system declared in diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 582027244c..0739534b57 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -24,6 +24,7 @@ #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix scripts build) + #:use-module (gnu system) #:use-module (gnu system vm) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) @@ -71,9 +72,15 @@ (define (show-help) (display (_ "Usage: guix system [OPTION] ACTION FILE Build the operating system declared in FILE according to ACTION.\n")) - (display (_ "Currently the only valid values for ACTION are 'vm', which builds -a virtual machine of the given operating system that shares the host's store, -and 'vm-image', which builds a virtual machine image that stands alone.\n")) + (newline) + (display (_ "The valid values for ACTION are:\n")) + (display (_ "\ + - 'build', build the operating system without installing anything\n")) + (display (_ "\ + - 'vm', build a virtual machine image that shares the host's store\n")) + (display (_ "\ + - 'vm-image', build a freestanding virtual machine image.\n")) + (show-build-options-help) (display (_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) @@ -131,9 +138,7 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n")) (alist-cons 'argument arg result))) (let ((action (string->symbol arg))) (case action - ((vm) - (alist-cons 'action action result)) - ((vm-image) + ((build vm vm-image) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) @@ -147,6 +152,8 @@ and 'vm-image', which builds a virtual machine image that stands alone.\n")) (read-operating-system file) (leave (_ "no configuration file specified~%")))) (mdrv (case action + ((build) + (operating-system-derivation os)) ((vm-image) (let ((size (assoc-ref opts 'image-size))) (system-qemu-image os -- cgit v1.2.3 From d216323f0ae66f9e95cfd370318a2231d0845981 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 21:57:11 +0200 Subject: hydra: Add dummy root file system declaration. * build-aux/hydra/demo-os.scm (file-systems): Add "/" file system. --- build-aux/hydra/demo-os.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index e36a9ca17d..32c6fa3abf 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -44,9 +44,13 @@ (timezone "Europe/Paris") (locale "en_US.UTF-8") (file-systems - ;; We don't provide a file system for /, but that's OK because the VM build + ;; We provide a dummy file system for /, but that's OK because the VM build ;; code will automatically declare the / file system for us. - (list ;; %fuse-control-file-system ; needs fuse.ko + (list (file-system + (mount-point "/") + (device "dummy") + (type "dummy")) + ;; %fuse-control-file-system ; needs fuse.ko %binary-format-file-system)) (users (list (user-account (name "guest") -- cgit v1.2.3 From 87a52da7d0da82bd8df9c86dcac7029c375b50c0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 May 2014 23:31:48 +0200 Subject: linux-initrd: Factorize kernel command-line option parsing. * guix/build/linux-initrd.scm (find-long-option): New procedure. (boot-system): Use it instead of the local 'option'. --- guix/build/linux-initrd.scm | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index a89ff86bbb..9093e72695 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -28,6 +28,7 @@ #:use-module (guix build utils) #:export (mount-essential-file-systems linux-command-line + find-long-option make-essential-device-nodes configure-qemu-networking check-file-system @@ -78,6 +79,15 @@ (call-with-input-file "/proc/cmdline" get-string-all))) +(define (find-long-option option arguments) + "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\". +Return the value associated with OPTION, or #f on failure." + (let ((opt (string-append option "="))) + (and=> (find (cut string-prefix? opt <>) + arguments) + (lambda (arg) + (substring arg (+ 1 (string-index arg #\=))))))) + (define* (make-essential-device-nodes #:key (root "/")) "Make essential device nodes under ROOT/dev." ;; The hand-made udev! @@ -411,14 +421,8 @@ to it are lost." (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"))) + (to-load (find-long-option "--load" args)) + (root (find-long-option "--root" args))) (when (member "--repl" args) (start-repl)) -- cgit v1.2.3 From e901ef297d9afe9a159dcf2bbd9779c9fbf822be Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 May 2014 00:08:39 +0200 Subject: store: Add #:store parameter to 'register-path'. * guix/store.scm (register-path): Add #:store and honor it. --- guix/store.scm | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/guix/store.scm b/guix/store.scm index 2b924db213..1731c14f27 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -797,17 +797,21 @@ signing them if SIGN? is true." (loop tail))))))) (define* (register-path path - #:key (references '()) deriver) + #:key (references '()) deriver store) "Register PATH as a valid store file, with REFERENCES as its list of -references, and DERIVER as its deriver (.drv that led to it.) Return #t on -success. +references, and DERIVER as its deriver (.drv that led to it.) If STORE is not +#f, it must be a string denoting the directory name of the new store to +initialize. Return #t on success. Use with care as it directly modifies the store! This is primarily meant to be used internally by the daemon's build hook." ;; Currently this is implemented by calling out to the fine C++ blob. (catch 'system-error (lambda () - (let ((pipe (open-pipe* OPEN_WRITE %guix-register-program))) + (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program + (if store + `("--prefix" ,store) + '())))) (and pipe (begin (format pipe "~a~%~a~%~a~%" -- cgit v1.2.3 From 1634c0420e5e8e609f5d52f5bf92eeafff5bfb6a Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sat, 17 May 2014 14:43:34 +0200 Subject: gnu: Add rasqal. * gnu/packages/rdf.scm (rasqal): New variable. --- gnu/packages/rdf.scm | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index 368245bbaa..4fc9b9e61f 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -27,6 +27,11 @@ #:use-module (gnu packages compression) #:use-module (gnu packages curl) #:use-module (gnu packages doxygen) + #:use-module (gnu packages gnupg) + #:use-module (gnu packages linux) + #:use-module (gnu packages multiprecision) + #:use-module (gnu packages pcre) + #:use-module (gnu packages perl) #:use-module (gnu packages pkg-config) #:use-module (gnu packages qt) #:use-module (gnu packages xml)) @@ -95,6 +100,46 @@ full-featured indexing and searching API. It is a port of the very popular Java Lucene text search engine API to C++.") (license lgpl2.1))) +(define-public rasqal + (package + (name "rasqal") + (version "0.9.32") + (source (origin + (method url-fetch) + (uri (string-append "http://download.librdf.org/source/" name + "-" version ".tar.gz")) + (sha256 + (base32 + "13rfprkk7d74065c7bafyshajwa6lshj7m9l741zlz9viqhh7fpf")))) + (build-system gnu-build-system) + (native-inputs + `(("perl" ,perl) + ("perl-xml-dom" ,perl-xml-dom) ; for the tests + ("pkg-config" ,pkg-config))) + (inputs + `(("libgcrypt" ,libgcrypt) + ("libxml2" ,libxml2) + ("mpfr" ,mpfr) + ("pcre" ,pcre) + ("raptor2" ,raptor2) + ("util-linux" ,util-linux))) + (arguments + `(#:parallel-tests? #f + ; test failure reported upstream, see + ; http://bugs.librdf.org/mantis/view.php?id=571 + #:tests? #f)) + (home-page "http://librdf.org/rasqal/") + (synopsis "RDF query library") + (description "Rasqal is a C library that handles Resource Description +Framework (RDF) query language syntaxes, query construction and execution +of queries returning results as bindings, boolean, RDF graphs/triples or +syntaxes. The supported query languages are SPARQL Query 1.0, +SPARQL Query 1.1, SPARQL Update 1.1 (no executing) and the Experimental +SPARQL extensions (LAQRS). Rasqal can write binding query results in the +SPARQL XML, SPARQL JSON, CSV, TSV, HTML, ASCII tables, RDF/XML and +Turtle/N3 and read them in SPARQL XML, RDF/XML and Turtle/N3. ") + (license lgpl2.1+))) ; or any choice of gpl2+ or asl2.0 + (define-public soprano (package (name "soprano") -- cgit v1.2.3 From 14af289ed9828850ceb341679e42aaa5db7912ee Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 May 2014 15:41:56 +0200 Subject: build: Add --with-libgcrypt-libdir=DIR to support Debian's multi-arch layout. * configure.ac: Remove 'LIBGCRYPT_PREFIX' and use 'LIBGCRYPT_LIBDIR' instead. Add --with-libgcrypt-libdir=DIR option. * Makefile.am (AM_DISTCHECK_CONFIGURE_FLAGS): Pass '--with-libgcrypt-libdir'. * config-daemon.ac: Honor $LIBGCRYPT_LIBDIR when computing LIBGCRYPT_LIBS. --- Makefile.am | 1 + config-daemon.ac | 12 ++++++++++-- configure.ac | 20 ++++++++++++++++++++ 3 files changed, 31 insertions(+), 2 deletions(-) diff --git a/Makefile.am b/Makefile.am index a08215ef1e..84f8eb1b63 100644 --- a/Makefile.am +++ b/Makefile.am @@ -259,6 +259,7 @@ endif BUILD_DAEMON ACLOCAL_AMFLAGS = -I m4 AM_DISTCHECK_CONFIGURE_FLAGS = \ --with-libgcrypt-prefix="$(LIBGCRYPT_PREFIX)" \ + --with-libgcrypt-libdir="$(LIBGCRYPT_LIBDIR)" \ --with-nix-prefix="$(NIX_PREFIX)" \ --enable-daemon diff --git a/config-daemon.ac b/config-daemon.ac index 08a72a0c4c..a13525a7f5 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -38,13 +38,21 @@ if test "x$guix_build_daemon" = "xyes"; then case "$LIBGCRYPT_PREFIX" in no) LIBGCRYPT_CFLAGS="" - LIBGCRYPT_LIBS="" ;; *) LIBGCRYPT_CFLAGS="-I$LIBGCRYPT_PREFIX/include" - LIBGCRYPT_LIBS="-L$LIBGCRYPT_PREFIX/lib -lgcrypt" ;; esac + + case "$LIBGCRYPT_LIBDIR" in + no) + LIBGCRYPT_LIBS="-lgcrypt" + ;; + *) + LIBGCRYPT_LIBS="-L$LIBGCRYPT_LIBDIR -lgcrypt" + ;; + esac + AC_SUBST([LIBGCRYPT_CFLAGS]) AC_SUBST([LIBGCRYPT_LIBS]) diff --git a/configure.ac b/configure.ac index 05e0370e6b..7b2a0e4dd5 100644 --- a/configure.ac +++ b/configure.ac @@ -116,19 +116,39 @@ AC_ARG_WITH([libgcrypt-prefix], yes|no) LIBGCRYPT="libgcrypt" LIBGCRYPT_PREFIX="no" + LIBGCRYPT_LIBDIR="no" ;; *) LIBGCRYPT="$withval/lib/libgcrypt" LIBGCRYPT_PREFIX="$withval" + LIBGCRYPT_LIBDIR="$withval/lib" ;; esac], [LIBGCRYPT="libgcrypt"]) +AC_ARG_WITH([libgcrypt-libdir], + [AS_HELP_STRING([--with-libgcrypt-libdir=DIR], + [search for GNU libgcrypt's shared library in DIR])], + [case "$withval" in + yes|no) + LIBGCRYPT="libgcrypt" + LIBGCRYPT_LIBDIR="no" + ;; + *) + LIBGCRYPT="$withval/libgcrypt" + LIBGCRYPT_LIBDIR="$withval" + ;; + esac], + [if test "x$LIBGCRYPT" = x; then + LIBGCRYPT="libgcrypt" + fi]) + dnl Library name suitable for `dynamic-link'. AC_MSG_CHECKING([for libgcrypt shared library name]) AC_MSG_RESULT([$LIBGCRYPT]) AC_SUBST([LIBGCRYPT]) AC_SUBST([LIBGCRYPT_PREFIX]) +AC_SUBST([LIBGCRYPT_LIBDIR]) GUIX_ASSERT_LIBGCRYPT_USABLE -- cgit v1.2.3 From 85d83c3b7b4fb3e970c8ad27856e9b34f1773cbc Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sat, 17 May 2014 14:55:27 +0200 Subject: gnu: rasqal: Propagate input raptor2. * gnu/packages/rdf.scm (rasqal): Propagate input raptor2 as indicated in the pkg-config file. --- gnu/packages/rdf.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index 4fc9b9e61f..2a4418e849 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -121,8 +121,9 @@ Java Lucene text search engine API to C++.") ("libxml2" ,libxml2) ("mpfr" ,mpfr) ("pcre" ,pcre) - ("raptor2" ,raptor2) ("util-linux" ,util-linux))) + (propagated-inputs + `(("raptor2" ,raptor2))) ; stipulated by rasqal.pc (arguments `(#:parallel-tests? #f ; test failure reported upstream, see -- cgit v1.2.3 From af6fce0fd146f5a73246476b7815bc13ddc3e527 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sat, 17 May 2014 14:59:15 +0200 Subject: gnu: Add redland. * gnu/packages/rdf.scm (redland): New variable. --- gnu/packages/rdf.scm | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index 2a4418e849..feee762e51 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -23,6 +23,7 @@ #:use-module (guix build-system cmake) #:use-module (guix build-system gnu) #:use-module (gnu packages) + #:use-module (gnu packages bdb) #:use-module (gnu packages boost) #:use-module (gnu packages compression) #:use-module (gnu packages curl) @@ -138,7 +139,31 @@ syntaxes. The supported query languages are SPARQL Query 1.0, SPARQL Query 1.1, SPARQL Update 1.1 (no executing) and the Experimental SPARQL extensions (LAQRS). Rasqal can write binding query results in the SPARQL XML, SPARQL JSON, CSV, TSV, HTML, ASCII tables, RDF/XML and -Turtle/N3 and read them in SPARQL XML, RDF/XML and Turtle/N3. ") +Turtle/N3 and read them in SPARQL XML, RDF/XML and Turtle/N3.") + (license lgpl2.1+))) ; or any choice of gpl2+ or asl2.0 + +(define-public redland + (package + (name "redland") + (version "1.0.17") + (source (origin + (method url-fetch) + (uri (string-append "http://download.librdf.org/source/" name + "-" version ".tar.gz")) + (sha256 + (base32 + "109n0kp39p966dpiasad2bb7q66rwbcb9avjvimw28chnpvlf66y")))) + (build-system gnu-build-system) + (native-inputs + `(("perl" ,perl) ; needed for installation + ("pkg-config" ,pkg-config))) + (inputs + `(("bdb" ,bdb) + ("rasqal" ,rasqal))) + (home-page "http://librdf.org/") + (synopsis "RDF library") + (description "The Redland RDF Library (librdf) provides the RDF API +and triple stores.") (license lgpl2.1+))) ; or any choice of gpl2+ or asl2.0 (define-public soprano -- cgit v1.2.3 From bf43449acefc343557f84c4c14ac83bceff799ad Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sat, 17 May 2014 17:12:27 +0200 Subject: gnu: soprano: Add input redland. * gnu/packages/rdf.scm (soprano): Add inputs redland and rasqal, drop raptor2 (propagated by rasqal). --- gnu/packages/rdf.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/rdf.scm b/gnu/packages/rdf.scm index feee762e51..7634e48018 100644 --- a/gnu/packages/rdf.scm +++ b/gnu/packages/rdf.scm @@ -180,14 +180,14 @@ and triple stores.") "1rg0x7yg0a1cbnxz7kqk52580wla8jbnj4d4r3j7l7g7ajyny1k4")) (patches (list (search-patch "soprano-find-clucene.patch"))))) (build-system cmake-build-system) - ;; FIXME: Add optional dependencies: Redland, odbci. (native-inputs `(("doxygen" ,doxygen) ("pkg-config" ,pkg-config))) (inputs `(("clucene" ,clucene) ("qt" ,qt-4) - ("raptor2" ,raptor2))) + ("rasqal" ,rasqal) + ("redland" ,redland))) (home-page "http://soprano.sourceforge.net/") (synopsis "RDF data library for Qt") (description "Soprano (formerly known as QRDF) is a library which -- cgit v1.2.3 From b4140694aca6a717ec130e3788b9d877d1b1e534 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 May 2014 17:39:30 +0200 Subject: system: Make /run/current-system at activation time. * gnu/system.scm (etc-directory): Change default value of #:profile. Change contents of SHELLS. Use /run/current-system/profile/{s,}bin in BASHRC. (operating-system-boot-script)[%modules]: Add (guix build linux-initrd). Add call to 'activate-current-system' in gexp. (operating-system-initrd-file, operating-system-grub.cfg): New procedures. (operating-system-derivation): Don't build grub.cfg here and remove it from the file union. * gnu/system/vm.scm (qemu-image): Remove #:populate. (operating-system-build-gid, operating-system-default-contents): Remove. (system-qemu-image): Remove call to 'operating-system-default-contents'. Use 'operating-system-grub.cfg' to get grub.cfg. Add GRUB.CFG to #:inputs. (system-qemu-image/shared-store): Likewise, but don't add GRUB.CFG to #:inputs. (system-qemu-image/shared-store-script): Pass --system kernel option. * guix/build/activation.scm (%booted-system, %current-system): New variables. (boot-time-system, activate-current-system): New procedures. * guix/build/install.scm (evaluate-populate-directive): Add case for ('directory name uid gid mode). (directives, populate-root-file-system): New procedures. * guix/build/vm.scm (initialize-hard-disk): Replace calls to 'evaluate-populate-directive' by a call to 'populate-root-file-system'. * gnu/services/dmd.scm (dmd-configuration-file): Use /run/current-system/profile/bin. * gnu/services/xorg.scm (slim-service): Likewise. --- gnu/services/dmd.scm | 2 +- gnu/services/xorg.scm | 2 +- gnu/system.scm | 56 ++++++++++++++++++++++++++++---------------- gnu/system/vm.scm | 59 ++++++----------------------------------------- guix/build/activation.scm | 33 +++++++++++++++++++++++++- guix/build/install.scm | 50 +++++++++++++++++++++++++++++++-------- guix/build/vm.scm | 3 +-- 7 files changed, 118 insertions(+), 87 deletions(-) diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 0d17285890..982c196fe4 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -64,7 +64,7 @@ services)) ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") + (setenv "PATH" "/run/current-system/profile/bin") (format #t "starting services...~%") (for-each start '#$(append-map service-provision services)))) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 1988cfa6a0..7215297f69 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -139,7 +139,7 @@ When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." (mlet %store-monad ((startx (or startx (xorg-start-command))) (xinitrc (xinitrc))) (text-file* "slim.cfg" " -default_path /run/current-system/bin +default_path /run/current-system/profile/bin default_xserver " startx " xserver_arguments :0 vt7 xauth_path " xauth "/bin/xauth diff --git a/gnu/system.scm b/gnu/system.scm index 9ce94d0230..ec3e2fcd6c 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -55,6 +55,7 @@ operating-system-derivation operating-system-profile + operating-system-grub.cfg file-system @@ -263,7 +264,7 @@ explicitly appear in OS." (locale "C") (timezone "Europe/Paris") (skeletons '()) (pam-services '()) - (profile "/var/run/current-system/profile") + (profile "/run/current-system/profile") (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad @@ -273,8 +274,8 @@ explicitly appear in OS." (shells (text-file "shells" ; used by xterm and others "\ /bin/sh -/run/current-system/bin/sh -/run/current-system/bin/bash\n")) +/run/current-system/profile/bin/sh +/run/current-system/profile/bin/bash\n")) (issue (text-file "issue" " This is an alpha preview of the GNU system. Welcome. @@ -293,8 +294,8 @@ export LC_ALL=\"" locale "\" export TZ=\"" timezone "\" export TZDIR=\"" tzdata "/share/zoneinfo\" -export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin -export PATH=/run/setuid-programs:$PATH +export PATH=/run/setuid-programs:/run/current-system/profile/sbin +export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin:$PATH export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' @@ -402,7 +403,8 @@ alias ll='ls -l' we're running in the final root." (define %modules '((guix build activation) - (guix build utils))) + (guix build utils) + (guix build linux-initrd))) (mlet* %store-monad ((services (operating-system-services os)) (etc (operating-system-etc-directory os)) @@ -446,6 +448,9 @@ we're running in the final root." ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) + ;; Set up /run/current-system. + (activate-current-system #:boot? #t) + ;; Close any remaining open file descriptors to be on the ;; safe side. This must be the very last thing we do, ;; because Guile has internal FDs such as 'sleep_pipe' @@ -466,8 +471,8 @@ we're running in the final root." (_ #f)) (operating-system-file-systems os))) -(define (operating-system-derivation os) - "Return a derivation that builds OS." +(define (operating-system-initrd-file os) + "Return a gexp denoting the initrd file of OS." (define boot-file-systems (filter (match-lambda (($ device "/") @@ -476,15 +481,16 @@ we're running in the final root." boot?)) (operating-system-file-systems os))) + (mlet %store-monad + ((initrd ((operating-system-initrd os) boot-file-systems))) + (return #~(string-append #$initrd "/initrd")))) + +(define (operating-system-grub.cfg os) + "Return the GRUB configuration file for OS." (mlet* %store-monad - ((profile (operating-system-profile os)) - (etc (operating-system-etc-directory os)) - (services (operating-system-services os)) - (boot (operating-system-boot-script os)) - (kernel -> (operating-system-kernel os)) - (initrd ((operating-system-initrd os) boot-file-systems)) - (initrd-file -> #~(string-append #$initrd "/initrd")) + ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) + (kernel -> (operating-system-kernel os)) (entries -> (list (menu-entry (label (string-append "GNU system with " @@ -494,15 +500,25 @@ we're running in the final root." (linux-arguments (list (string-append "--root=" (file-system-device root-fs)) - #~(string-append "--load=" #$boot))) - (initrd initrd-file)))) - (grub.cfg (grub-configuration-file entries))) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system + "/boot"))) + (initrd #~(string-append #$system "/initrd")))))) + (grub-configuration-file entries))) + +(define (operating-system-derivation os) + "Return a derivation that builds OS." + (mlet* %store-monad + ((profile (operating-system-profile os)) + (etc (operating-system-etc-directory os)) + (boot (operating-system-boot-script os)) + (kernel -> (operating-system-kernel os)) + (initrd (operating-system-initrd-file os))) (file-union "system" `(("boot" ,#~#$boot) ("kernel" ,#~#$kernel) - ("initrd" ,initrd-file) + ("initrd" ,initrd) ("profile" ,#~#$profile) - ("grub.cfg" ,#~#$grub.cfg) ("etc" ,#~#$etc))))) ;;; system.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 58e5416b3e..4bf0e06081 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,7 +192,6 @@ made available under the /xchg CIFS share." (file-system-type "ext4") grub-configuration (register-closures? #t) - (populate #f) (inputs '()) copy-inputs?) "Return a bootable, stand-alone QEMU image, with a root partition of type @@ -203,12 +202,7 @@ file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in -the image. - -POPULATE is a list of directives stating directories or symlinks to be created -in the disk image partition. It is evaluated once the image has been -populated with INPUTS-TO-COPY. It can be used to provide additional files, -such as /etc files." +the image." (mlet %store-monad ((graph (sequence %store-monad (map input->name+output inputs)))) (expression->derivation-in-linux-vm @@ -241,8 +235,7 @@ such as /etc files." #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? #:disk-image-size #$disk-image-size - #:file-system-type #$file-system-type - #:directives '#$populate) + #:file-system-type #$file-system-type) (reboot)))) #:system system #:make-disk-image? #t @@ -254,39 +247,6 @@ such as /etc files." ;;; Stand-alone VM image. ;;; -(define (operating-system-build-gid os) - "Return as a monadic value the group id for build users of OS, or #f." - (mlet %store-monad ((services (operating-system-services os))) - (return (any (lambda (service) - (and (equal? '(guix-daemon) - (service-provision service)) - (match (service-user-groups service) - ((group) - (user-group-id group))))) - services)))) - -(define (operating-system-default-contents os) - "Return a list of directives suitable for 'system-qemu-image' describing the -basic contents of the root file system of OS." - (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (build-gid (operating-system-build-gid os)) - (profile (operating-system-profile os))) - (return #~((directory #$(%store-prefix) 0 #$(or build-gid 0)) - (directory "/etc") - (directory "/var/log") ; for dmd - (directory "/var/run/nscd") - (directory "/var/guix/gcroots") - ("/var/guix/gcroots/system" -> #$os-drv) - (directory "/run") - ("/run/current-system" -> #$profile) - (directory "/bin") - ("/bin/sh" -> "/run/current-system/bin/bash") - (directory "/tmp") - (directory "/var/guix/profiles/per-user/root" 0 0) - - (directory "/root" 0 0) ; an exception - (directory "/home" 0 0))))) - (define* (system-qemu-image os #:key (file-system-type "ext4") @@ -312,14 +272,12 @@ of the GNU system as described by OS." file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) + (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:grub-configuration grub.cfg - #:populate populate #:disk-image-size disk-image-size #:file-system-type file-system-type - #:inputs `(("system" ,os-drv)) + #:inputs `(("system" ,os-drv) + ("grub.cfg" ,grub.cfg)) #:copy-inputs? #t)))) (define (virtualized-operating-system os) @@ -356,11 +314,8 @@ environment with the store shared with the host." with the host." (mlet* %store-monad ((os-drv (operating-system-derivation os)) - (os-dir -> (derivation->output-path os-drv)) - (grub.cfg -> (string-append os-dir "/grub.cfg")) - (populate (operating-system-default-contents os))) + (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:grub-configuration grub.cfg - #:populate populate #:disk-image-size disk-image-size #:inputs `(("system" ,os-drv)) @@ -390,7 +345,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir -kernel " #$(operating-system-kernel os) "/bzImage \ -initrd " #$os-drv "/initrd \ -append \"" #$(if graphic? "" "console=ttyS0 ") - "--load=" #$os-drv "/boot --root=/dev/vda1\" \ + "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" \ -serial stdio \ -drive file=" #$image ",if=virtio,cache=writeback,werror=report,readonly\n") diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 267c592b52..49f98c021d 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -18,13 +18,15 @@ (define-module (guix build activation) #:use-module (guix build utils) + #:use-module (guix build linux-initrd) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (activate-users+groups activate-etc - activate-setuid-programs)) + activate-setuid-programs + activate-current-system)) ;;; Commentary: ;;; @@ -195,4 +197,33 @@ numeric gid or #f." (for-each make-setuid-program programs)) +(define %booted-system + ;; The system we booted in (a symlink.) + "/run/booted-system") + +(define %current-system + ;; The system that is current (a symlink.) This is not necessarily the same + ;; as %BOOTED-SYSTEM, for instance because we can re-build a new system + ;; configuration and activate it, without rebooting. + "/run/current-system") + +(define (boot-time-system) + "Return the '--system' argument passed on the kernel command line." + (find-long-option "--system" (linux-command-line))) + +(define* (activate-current-system #:optional (system (boot-time-system)) + #:key boot?) + "Atomically make SYSTEM the current system. When BOOT? is true, also make +it the booted system." + (format #t "making '~a' the current system...~%" system) + (when boot? + (when (file-exists? %booted-system) + (delete-file %booted-system)) + (symlink system %booted-system)) + + ;; Atomically make SYSTEM current. + (let ((new (string-append %current-system ".new"))) + (symlink system new) + (rename-file new %current-system))) + ;;; activation.scm ends here diff --git a/guix/build/install.scm b/guix/build/install.scm index 37153703e5..a0be6e9d39 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -19,9 +19,10 @@ (define-module (guix build install) #:use-module (guix build utils) #:use-module (guix build install) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (install-grub - evaluate-populate-directive + populate-root-file-system reset-timestamps register-closure)) @@ -46,15 +47,44 @@ MOUNT-POINT. Return #t on success." (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under directory TARGET." - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - ((new '-> old) - (symlink old (string-append target new))))) + (let loop ((directive directive)) + (match directive + (('directory name) + (mkdir-p (string-append target name))) + (('directory name uid gid) + (let ((dir (string-append target name))) + (mkdir-p dir) + (chown dir uid gid))) + (('directory name uid gid mode) + (loop `(directory ,name ,uid ,gid)) + (chmod (string-append target name) mode)) + ((new '-> old) + (symlink old (string-append target new)))))) + +(define (directives store) + "Return a list of directives to populate the root file system that will host +STORE." + `((directory ,store 0 0) + (directory "/etc") + (directory "/var/log") ; for dmd + (directory "/var/run/nscd") + (directory "/var/guix/gcroots") + (directory "/run") + ("/var/guix/gcroots/booted-system" -> "/run/booted-system") + ("/var/guix/gcroots/current-system" -> "/run/current-system") + (directory "/bin") + ("/bin/sh" -> "/run/current-system/profile/bin/bash") + (directory "/tmp" 0 0 #o1777) ; sticky bit + (directory "/var/guix/profiles/per-user/root" 0 0) + + (directory "/root" 0 0) ; an exception + (directory "/home" 0 0))) + +(define (populate-root-file-system target) + "Make the essential non-store files and directories on TARGET. This +includes /etc, /var, /run, /bin/sh, etc." + (for-each (cut evaluate-populate-directive <> target) + (directives (%store-directory)))) (define (reset-timestamps directory) "Reset the timestamps of all the files under DIRECTORY, so that they appear diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 12f952bd11..b9bb66cdb7 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -206,8 +206,7 @@ further populate the partition." ;; Evaluate the POPULATE directives. (display "populating...\n") - (for-each (cut evaluate-populate-directive <> target-directory) - directives) + (populate-root-file-system target-directory) (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) -- cgit v1.2.3 From 1691b4cdc619caf47700eef22023066985afb877 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Sun, 18 May 2014 11:08:17 -0500 Subject: gnu: openmpi: Add memchecker support. * gnu/packages/mpi.scm (openmpi) [inputs]: Add valgrind. Unpropagate gfortran. [arguments]: Add configure flags for memchecker. --- gnu/packages/mpi.scm | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/gnu/packages/mpi.scm b/gnu/packages/mpi.scm index 37b7858469..e7919bc436 100644 --- a/gnu/packages/mpi.scm +++ b/gnu/packages/mpi.scm @@ -32,6 +32,7 @@ #:use-module (gnu packages xml) #:use-module (gnu packages ncurses) #:use-module (gnu packages pkg-config) + #:use-module (gnu packages valgrind) #:use-module (srfi srfi-1)) (define-public hwloc @@ -95,11 +96,11 @@ bind processes, and much more.") "13z1q69f3qwmmhpglarfjminfy2yw4rfqr9jydjk5507q3mjf50p")))) (build-system gnu-build-system) (inputs - `(("hwloc" ,hwloc))) + `(("hwloc" ,hwloc) + ("gfortran" ,gfortran-4.8) + ("valgrind" ,valgrind))) (native-inputs `(("pkg-config" ,pkg-config))) - (propagated-inputs - `(("gfortran" ,gfortran-4.8))) (arguments `(#:configure-flags `("--enable-static" "--enable-oshmem" @@ -110,6 +111,10 @@ bind processes, and much more.") ;; "--enable-mpi-thread-multiple" "--enable-mpi-ext=all" "--with-devel-headers" + "--enable-debug" + "--enable-memchecker" + ,(string-append "--with-valgrind=" + (assoc-ref %build-inputs "valgrind")) ,(string-append "--with-hwloc=" (assoc-ref %build-inputs "hwloc"))))) (home-page "http://www.open-mpi.org") -- cgit v1.2.3 From 15d299874c635d14a84710005d0ed4b05968ff6f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 19:11:53 +0200 Subject: vm: Avoid resetting timestamps twice. * guix/build/vm.scm (initialize-hard-disk): Don't call 'reset-timestamps' when REGISTER-CLOSURES? is true. * guix/build/install.scm (register-closure): Mention timestamps in docstring. --- guix/build/install.scm | 2 +- guix/build/vm.scm | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/guix/build/install.scm b/guix/build/install.scm index a0be6e9d39..564735a7f6 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -103,7 +103,7 @@ as created and modified at the Epoch." (define (register-closure store closure) "Register CLOSURE in STORE, where STORE is the directory name of the target store and CLOSURE is the name of a file containing a reference graph as used -by 'guix-register'." +by 'guix-register'. As a side effect, this resets timestamps on store files." (let ((status (system* "guix-register" "--prefix" store closure))) (unless (zero? status) diff --git a/guix/build/vm.scm b/guix/build/vm.scm index b9bb66cdb7..e67b431b5a 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -211,7 +211,10 @@ further populate the partition." (unless (install-grub grub.cfg "/dev/sda" target-directory) (error "failed to install GRUB")) - (reset-timestamps target-directory) + ;; 'guix-register' resets timestamps and everything, so no need to do it + ;; once more in that case. + (unless register-closures? + (reset-timestamps target-directory)) (zero? (system* "umount" target-directory))) -- cgit v1.2.3 From bb31e0a3ee2ba23fa7a57471b0aa2363404f4c27 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 19:12:43 +0200 Subject: store: Change #:store parameter to #:prefix. * guix/store.scm (register-path): Change #:store to #:prefix. --- guix/store.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/guix/store.scm b/guix/store.scm index 1731c14f27..073e024e38 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -797,10 +797,10 @@ signing them if SIGN? is true." (loop tail))))))) (define* (register-path path - #:key (references '()) deriver store) + #:key (references '()) deriver prefix) "Register PATH as a valid store file, with REFERENCES as its list of -references, and DERIVER as its deriver (.drv that led to it.) If STORE is not -#f, it must be a string denoting the directory name of the new store to +references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is +not #f, it must be the name of the directory containing the new store to initialize. Return #t on success. Use with care as it directly modifies the store! This is primarily meant to @@ -809,8 +809,8 @@ be used internally by the daemon's build hook." (catch 'system-error (lambda () (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program - (if store - `("--prefix" ,store) + (if prefix + `("--prefix" ,prefix) '())))) (and pipe (begin -- cgit v1.2.3 From 72b9d60df4723541e1a65f7a3d14abb757fbed97 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 21:32:57 +0200 Subject: guix system: Add 'init' sub-command. * guix/scripts/system.scm (install): New procedure. (guix-system)[parse-option]: Remove check for extraneous arguments. [match-pair, option-arguments]: New procedures. Use 'option-arguments'. Honor 'init'. (show-help): Document 'init'. * doc/guix.texi (Invoking guix system): Document 'init'. --- doc/guix.texi | 15 +++++++++ guix/scripts/system.scm | 87 ++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 93 insertions(+), 9 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 4881ec6e1b..4c32df3c9f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3209,6 +3209,21 @@ Build the operating system's derivation, which includes all the configuration files and programs needed to boot and run the system. This action does not actually install anything. +@item init +Populate the given directory with all the files necessary to run the +operating system specified in @var{file}. This is useful for first-time +installations of the GNU system. For instance: + +@example +guix system init my-os-config.scm /mnt +@end example + +copies to @file{/mnt} all the store items required by the configuration +specified in @file{my-os-config.scm}. This includes configuration +files, packages, and so on. It also creates other essential files +needed for the system to operate correctly---e.g., the @file{/etc}, +@file{/var}, and @file{/run} directories, and the @file{/bin/sh} file. + @item vm @cindex virtual machine Build a virtual machine that contain the operating system declared in diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 0739534b57..ee5df6e951 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -19,14 +19,18 @@ (define-module (guix scripts system) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix scripts build) + #:use-module (guix build utils) + #:use-module (guix build install) #:use-module (gnu system) #:use-module (gnu system vm) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (guix-system @@ -64,6 +68,38 @@ (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) +(define* (install store os-dir target + #:key (log-port (current-output-port))) + "Copy OS-DIR and its dependencies to directory TARGET. TARGET must be an +absolute directory name since that's what 'guix-register' expects." + (define to-copy + (let ((lst (delete-duplicates (cons os-dir (references store os-dir)) + string=?))) + (topologically-sorted store lst))) + + ;; Copy items to the new store. + (for-each (lambda (item) + (let ((dest (string-append target item)) + (refs (references store item))) + (format log-port "copying '~a'...~%" item) + (copy-recursively item dest + #:log (%make-void-port "w")) + + ;; Register ITEM; as a side-effect, it resets timestamps, etc. + (unless (register-path item + #:prefix target + #:references refs) + (leave (_ "failed to register '~a' under '~a'~%") + item target)))) + to-copy) + + ;; Create a bunch of additional files. + (format log-port "populating '~a'...~%" target) + (populate-root-file-system target) + + ;; TODO: Install GRUB. + ) + ;;; ;;; Options. @@ -79,7 +115,9 @@ Build the operating system declared in FILE according to ACTION.\n")) (display (_ "\ - 'vm', build a virtual machine image that shares the host's store\n")) (display (_ "\ - - 'vm-image', build a freestanding virtual machine image.\n")) + - 'vm-image', build a freestanding virtual machine image\n")) + (display (_ "\ + - 'init', initialize a root file system to run GNU.\n")) (show-build-options-help) (display (_ " @@ -132,27 +170,50 @@ Build the operating system declared in FILE according to ACTION.\n")) (leave (_ "~A: unrecognized option~%") name)) (lambda (arg result) (if (assoc-ref result 'action) - (let ((previous (assoc-ref result 'argument))) - (if previous - (leave (_ "~a: extraneous argument~%") previous) - (alist-cons 'argument arg result))) + (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((build vm vm-image) + ((build vm vm-image init) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) %default-options)) + (define (match-pair car) + ;; Return a procedure that matches a pair with CAR. + (match-lambda + ((head . tail) + (and (eq? car head) tail)) + (_ #f))) + + (define (option-arguments opts) + ;; Extract the plain arguments from OPTS. + (let* ((args (reverse (filter-map (match-pair 'argument) opts))) + (count (length args)) + (action (assoc-ref opts 'action))) + (define (fail) + (leave (_ "wrong number of arguments for action '~a'~%") + action)) + + (case action + ((build vm vm-image) + (unless (= count 1) + (fail))) + ((init) + (unless (= count 2) + (fail)))) + args)) + (with-error-handling (let* ((opts (parse-options)) - (file (assoc-ref opts 'argument)) + (args (option-arguments opts)) + (file (first args)) (action (assoc-ref opts 'action)) (os (if file (read-operating-system file) (leave (_ "no configuration file specified~%")))) (mdrv (case action - ((build) + ((build init) (operating-system-derivation os)) ((vm-image) (let ((size (assoc-ref opts 'image-size))) @@ -171,4 +232,12 @@ Build the operating system declared in FILE according to ACTION.\n")) (unless dry? (build-derivations store (list drv)) (display (derivation->output-path drv)) - (newline))))) + (newline) + + (when (eq? action 'init) + (let ((target (second args))) + (format #t (_ "initializing operating system under '~a'...~%") + target) + + (install store (derivation->output-path drv) + (canonicalize-path target)))))))) -- cgit v1.2.3 From d5b429abda948c21a61032a1da9d472410edaa90 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 21:58:01 +0200 Subject: system: Add 'grub-configuration' record. * gnu/system/grub.scm (): New record type. (grub-configuration-file): Add 'config' parameter; remove #:default-entry and #:timeout. Honor CONFIG. * gnu/system.scm (): Remove 'bootloader-entries' field; remove default value for 'bootloader' field. (operating-system-grub.cfg): Pass the 'bootloader' field to 'grub-configuration-file'. * build-aux/hydra/demo-os.scm (bootloader): New field. --- build-aux/hydra/demo-os.scm | 3 +++ gnu/system.scm | 11 +++++------ gnu/system/grub.scm | 39 ++++++++++++++++++++++++++++++--------- 3 files changed, 38 insertions(+), 15 deletions(-) diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 32c6fa3abf..fe9c77242e 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -33,6 +33,7 @@ (gnu packages tor) (gnu packages package-management) + (gnu system grub) ; 'grub-configuration' (gnu system shadow) ; 'user-account' (gnu system linux) ; 'base-pam-services' (gnu services base) @@ -43,6 +44,8 @@ (host-name "gnu") (timezone "Europe/Paris") (locale "en_US.UTF-8") + (bootloader (grub-configuration + (device "/dev/sda"))) (file-systems ;; We provide a dummy file system for /, but that's OK because the VM build ;; code will automatically declare the / file system for us. diff --git a/gnu/system.scm b/gnu/system.scm index ec3e2fcd6c..dd44878462 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -39,10 +39,11 @@ #:use-module (srfi srfi-26) #:export (operating-system operating-system? + + operating-system-bootloader operating-system-services operating-system-user-services operating-system-packages - operating-system-bootloader-entries operating-system-host-name operating-system-kernel operating-system-initrd @@ -83,10 +84,8 @@ operating-system? (kernel operating-system-kernel ; package (default linux-libre)) - (bootloader operating-system-bootloader ; package - (default grub)) - (bootloader-entries operating-system-bootloader-entries ; list - (default '())) + (bootloader operating-system-bootloader) ; + (initrd operating-system-initrd ; (list fs) -> M derivation (default qemu-initrd)) @@ -504,7 +503,7 @@ we're running in the final root." #~(string-append "--load=" #$system "/boot"))) (initrd #~(string-append #$system "/initrd")))))) - (grub-configuration-file entries))) + (grub-configuration-file (operating-system-bootloader os) entries))) (define (operating-system-derivation os) "Return a derivation that builds OS." diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 1893672a2a..e789e4c591 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -25,8 +25,13 @@ #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:export (menu-entry + #:export (grub-configuration + grub-configuration? + grub-configuration-device + + menu-entry menu-entry? + grub-configuration-file)) ;;; Commentary: @@ -35,6 +40,19 @@ ;;; ;;; Code: +(define-record-type* + grub-configuration make-grub-configuration + grub-configuration? + (grub grub-configuration-grub ; package + (default (@ (gnu packages grub) grub))) + (device grub-configuration-device) ; string + (menu-entries grub-configuration-menu-entries ; list + (default '())) + (default-entry grub-configuration-default-entry ; integer + (default 1)) + (timeout grub-configuration-timeout ; integer + (default 5))) + (define-record-type* menu-entry make-menu-entry menu-entry? @@ -44,11 +62,13 @@ (default '())) ; list of string-valued gexps (initrd menu-entry-initrd)) ; file name of the initrd as a gexp -(define* (grub-configuration-file entries - #:key (default-entry 1) (timeout 5) - (system (%current-system))) - "Return the GRUB configuration file for ENTRIES, a list of - objects, defaulting to DEFAULT-ENTRY and with the given TIMEOUT." +(define* (grub-configuration-file config entries + #:key (system (%current-system))) + "Return the GRUB configuration file corresponding to CONFIG, a + object." + (define all-entries + (append entries (grub-configuration-menu-entries config))) + (define entry->gexp (match-lambda (($ label linux arguments initrd) @@ -67,12 +87,13 @@ set default=~a set timeout=~a search.file ~a/bzImage~%" - #$default-entry #$timeout + #$(grub-configuration-default-entry config) + #$(grub-configuration-timeout config) #$(any (match-lambda (($ _ linux) linux)) - entries)) - #$@(map entry->gexp entries)))) + all-entries)) + #$@(map entry->gexp all-entries)))) (gexp->derivation "grub.cfg" builder)) -- cgit v1.2.3 From 6ffd11f129405c7bd663201096d8fcfcde6344a9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 May 2014 22:06:38 +0200 Subject: system: Prevent grub.cfg from being GC'd. * guix/build/install.scm (install-grub): Use 'copy-file' instead of 'symlink' for GRUB.CFG. --- guix/build/install.scm | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/guix/build/install.scm b/guix/build/install.scm index 564735a7f6..f61c16f13a 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -38,11 +38,18 @@ (define* (install-grub grub.cfg device mount-point) "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on MOUNT-POINT. Return #t on success." - (mkdir-p (string-append mount-point "/boot/grub")) - (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg")) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device))) + (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) + (pivot (string-append target ".new"))) + (mkdir-p (dirname target)) + + ;; Copy GRUB.CFG instead of just symlinking it since it's not a GC root. + ;; Do that atomically. + (copy-file grub.cfg pivot) + (rename-file pivot target) + + (zero? (system* "grub-install" "--no-floppy" + "--boot-directory" (string-append mount-point "/boot") + device)))) (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under -- cgit v1.2.3 From c711f07c3e1f512fbd6d61ab5acc62064ad46697 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Sun, 18 May 2014 23:49:07 -0500 Subject: guix: licenses: Add CeCILL-C license. * guix/licenses.scm (cecill-c): New variable. --- guix/licenses.scm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/guix/licenses.scm b/guix/licenses.scm index fce3d2b896..c3464b5f5f 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -26,6 +26,7 @@ boost1.0 bsd-2 bsd-3 bsd-4 bsd-style cddl1.0 + cecill-c cpl1.0 epl1.0 expat @@ -112,6 +113,11 @@ which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:CDDLv1.0" "https://www.gnu.org/licenses/license-list#CDDL")) +(define cecill-c + (license "CeCILL-C" + "http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html" + "https://www.gnu.org/licenses/license-list.html#CeCILL")) + (define cpl1.0 (license "CPL 1.0" "http://directory.fsf.org/wiki/License:CPLv1.0" -- cgit v1.2.3 From f8ed036a317ee87ced2422d61c84a821b15fb5e1 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Mon, 19 May 2014 00:08:30 -0500 Subject: gnu: Add scotch package. * gnu/packages/maths.scm (scotch): New variable. * gnu/packages/patches/scotch-test-threading.patch: New patch. * gnu-system.am (dist_patch_DATA): Add it. --- gnu-system.am | 1 + gnu/packages/maths.scm | 77 +++++++++++++ gnu/packages/patches/scotch-test-threading.patch | 139 +++++++++++++++++++++++ 3 files changed, 217 insertions(+) create mode 100644 gnu/packages/patches/scotch-test-threading.patch diff --git a/gnu-system.am b/gnu-system.am index b54aba1ab7..829c9979e5 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -339,6 +339,7 @@ dist_patch_DATA = \ gnu/packages/patches/readline-link-ncurses.patch \ gnu/packages/patches/ripperx-libm.patch \ gnu/packages/patches/scheme48-tests.patch \ + gnu/packages/patches/scotch-test-threading.patch \ gnu/packages/patches/slim-session.patch \ gnu/packages/patches/slim-config.patch \ gnu/packages/patches/slim-sigusr1.patch \ diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 49fdacef04..2fe06a3956 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -589,3 +589,80 @@ library routines perform an LU decomposition with partial pivoting and triangular system solves through forward and back substitution. The library also provides threshold-based ILU factorization preconditioners.") (license license:bsd-3))) + +(define-public scotch + (package + (name "scotch") + (version "6.0.0") + (source + (origin + (method url-fetch) + (uri (string-append "https://gforge.inria.fr/frs/download.php/31831/" + "scotch_" version ".tar.gz")) + (sha256 + (base32 "0yfqf9lk7chb3h42777x42x4adx0v3n0b41q0cdqrdmscp4iczp5")) + (patches (list (search-patch "scotch-test-threading.patch"))))) + (build-system gnu-build-system) + (inputs + `(("zlib" ,zlib) + ("flex" ,flex) + ("bison" ,bison))) + (arguments + `(#:phases + (alist-cons-after + 'unpack 'chdir-to-src + (lambda _ (chdir "src")) + (alist-replace + 'configure + (lambda _ + (call-with-output-file "Makefile.inc" + (lambda (port) + (format port " +EXE = +LIB = .a +OBJ = .o +MAKE = make +AR = ar +ARFLAGS = -ruv +CCS = gcc +CCP = mpicc +CCD = gcc +CPPFLAGS =~{ -D~a~} +CFLAGS = -O2 -g $(CPPFLAGS) +LDFLAGS = -lz -lm -lrt -lpthread +CP = cp +LEX = flex -Pscotchyy -olex.yy.c +LN = ln +MKDIR = mkdir +MV = mv +RANLIB = ranlib +YACC = bison -pscotchyy -y -b y +" + '("COMMON_FILE_COMPRESS_GZ" + "COMMON_PTHREAD" + "COMMON_RANDOM_FIXED_SEED" + ;; TODO: Define once our MPI supports + ;; MPI_THREAD_MULTIPLE + ;; "SCOTCH_PTHREAD" + ;; "SCOTCH_PTHREAD_NUMBER=2" + "restrict=__restrict"))))) + (alist-replace + 'install + (lambda* (#:key outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (mkdir out) + (zero? (system* "make" + (string-append "prefix=" out) + "install")))) + %standard-phases))))) + (home-page "http://www.labri.fr/perso/pelegrin/scotch/") + (synopsis "Programs and libraries for graph algorithms") + (description "SCOTCH is a set of programs and libraries which implement +the static mapping and sparse matrix reordering algorithms developed within +the SCOTCH project. Its purpose is to apply graph theory, with a divide and +conquer approach, to scientific computing problems such as graph and mesh +partitioning, static mapping, and sparse matrix ordering, in application +domains ranging from structural mechanics to operating systems or +bio-chemistry.") + ;; See LICENSE_en.txt + (license license:cecill-c))) diff --git a/gnu/packages/patches/scotch-test-threading.patch b/gnu/packages/patches/scotch-test-threading.patch new file mode 100644 index 0000000000..2527a6e6dd --- /dev/null +++ b/gnu/packages/patches/scotch-test-threading.patch @@ -0,0 +1,139 @@ +* These tests assume threading support, even when the library is compiled + without it. Protect these checks. + +* Tests should not require keyboard interaction. + +--- a/src/check/test_scotch_dgraph_band.c 2012-09-27 10:46:42.000000000 -0500 ++++ b/src/check/test_scotch_dgraph_band.c 2014-05-13 14:36:07.479270243 -0500 +@@ -99,10 +99,12 @@ + errorPrint ("main: Cannot initialize (1)"); + exit (1); + } ++#ifdef SCOTCH_PTHREAD + if (thrdlvlreqval > thrdlvlproval) { + errorPrint ("main: Cannot initialize (2)"); + exit (1); + } ++#endif + + if (argc != 2) { + errorPrint ("main: invalid number of parameters"); +@@ -115,12 +117,14 @@ + + fprintf (stderr, "Proc %2d of %2d, pid %d\n", proclocnum, procglbnbr, getpid ()); + ++#ifdef SCOTCH_DEBUG_CHECK2 + if (proclocnum == 0) { /* Synchronize on keybord input */ + char c; + + printf ("Waiting for key press...\n"); + scanf ("%c", &c); + } ++#endif /* SCOTCH_DEBUG_CHECK2 */ + + if (MPI_Barrier (proccomm) != MPI_SUCCESS) { /* Synchronize for debug */ + errorPrint ("main: cannot communicate"); +--- a/src/check/test_scotch_dgraph_grow.c 2012-11-30 12:19:33.000000000 -0600 ++++ b/src/check/test_scotch_dgraph_grow.c 2014-05-13 14:35:31.307269303 -0500 +@@ -103,10 +103,12 @@ + errorPrint ("main: Cannot initialize (1)"); + exit (1); + } ++#ifdef SCOTCH_PTHREAD + if (thrdlvlreqval > thrdlvlproval) { + errorPrint ("main: Cannot initialize (2)"); + exit (1); + } ++#endif + + if (argc != 2) { + errorPrint ("main: invalid number of parameters"); +@@ -119,12 +121,14 @@ + + fprintf (stderr, "Proc %2d of %2d, pid %d\n", proclocnum, procglbnbr, getpid ()); + ++#ifdef SCOTCH_DEBUG_CHECK2 + if (proclocnum == 0) { /* Synchronize on keybord input */ + char c; + + printf ("Waiting for key press...\n"); + scanf ("%c", &c); + } ++#endif /* SCOTCH_DEBUG_CHECK2 */ + + if (MPI_Barrier (proccomm) != MPI_SUCCESS) { /* Synchronize for debug */ + errorPrint ("main: cannot communicate"); +--- a/src/check/test_scotch_dgraph_redist.c 2012-09-26 11:42:27.000000000 -0500 ++++ b/src/check/test_scotch_dgraph_redist.c 2014-05-13 14:34:30.323267722 -0500 +@@ -98,10 +98,12 @@ + errorPrint ("main: Cannot initialize (1)"); + exit (1); + } ++#ifdef SCOTCH_PTHREAD + if (thrdlvlreqval > thrdlvlproval) { + errorPrint ("main: Cannot initialize (2)"); + exit (1); + } ++#endif + + if (argc != 2) { + errorPrint ("main: invalid number of parameters"); +@@ -114,7 +116,6 @@ + + fprintf (stderr, "Proc %2d of %2d, pid %d\n", proclocnum, procglbnbr, getpid ()); + +-#define SCOTCH_DEBUG_CHECK2 + #ifdef SCOTCH_DEBUG_CHECK2 + if (proclocnum == 0) { /* Synchronize on keybord input */ + char c; +--- /tmp/nix-build-scotch-6.0.0.drv-9/scotch_6.0.0/src/check/test_common_thread.c 2012-11-30 11:05:23.000000000 -0600 ++++ scotch_6.0.0/src/check/test_common_thread.c 2014-05-13 17:26:27.159535244 -0500 +@@ -90,7 +90,7 @@ + /* */ + /*************************/ + +-#if ((defined COMMON_PTHREAD) || (defined SCOTCH_PTHREAD)) ++#ifdef SCOTCH_PTHREAD + + static + void +@@ -161,7 +161,7 @@ + return (o); + } + +-#endif /* ((defined COMMON_PTHREAD) || (defined SCOTCH_PTHREAD)) */ ++#endif /* SCOTCH_PTHREAD */ + + /*********************/ + /* */ +@@ -175,14 +175,14 @@ + char * argv[]) + { + TestThreadGroup groudat; +-#if ((defined COMMON_PTHREAD) || (defined SCOTCH_PTHREAD)) ++#ifdef SCOTCH_PTHREAD + TestThread * restrict thrdtab; + int thrdnbr; +-#endif /* ((defined COMMON_PTHREAD) || (defined SCOTCH_PTHREAD)) */ ++#endif /* SCOTCH_PTHREAD */ + + SCOTCH_errorProg (argv[0]); + +-#if ((defined COMMON_PTHREAD) || (defined SCOTCH_PTHREAD)) ++#ifdef SCOTCH_PTHREAD + thrdnbr = SCOTCH_PTHREAD_NUMBER; + + groudat.redusum = COMPVAL (thrdnbr); +@@ -197,9 +197,9 @@ + errorPrint ("main: cannot launch or run threads"); + return (1); + } +-#else /* ((defined COMMON_PTHREAD) || (defined SCOTCH_PTHREAD)) */ +- printf ("Scotch not compiled with either COMMON_PTHREAD or SCOTCH_PTHREAD\n"); +-#endif /* ((defined COMMON_PTHREAD) || (defined SCOTCH_PTHREAD)) */ ++#else /* not SCOTCH_PTHREAD */ ++ printf ("Scotch not compiled with SCOTCH_PTHREAD\n"); ++#endif /* not SCOTCH_PTHREAD */ + + return (0); + } -- cgit v1.2.3 From 6acb4adb34a1b76744c024c945cca5cfdbdfffc5 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Mon, 19 May 2014 00:09:15 -0500 Subject: gnu: Add pt-scotch package. * gnu/packages/maths.scm (pt-scotch): New variable. --- gnu/packages/maths.scm | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 2fe06a3956..9288ba91f4 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -666,3 +666,33 @@ domains ranging from structural mechanics to operating systems or bio-chemistry.") ;; See LICENSE_en.txt (license license:cecill-c))) + +(define-public pt-scotch + (package (inherit scotch) + (name "pt-scotch") + (propagated-inputs + `(("openmpi" ,openmpi))) ;Headers include MPI headers + (arguments + (substitute-keyword-arguments (package-arguments scotch) + ((#:phases scotch-phases) + `(alist-replace + 'build + ;; TODO: Would like to add parallelism here + (lambda _ + (and + (zero? (system* "make" "ptscotch")) + ;; Install the serial metis compatibility library + (zero? (system* "make" "-C" "libscotchmetis" "install")))) + (alist-replace + 'check + (lambda _ (zero? (system* "make" "ptcheck"))) + (alist-replace + 'install + (lambda* (#:key outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (mkdir out) + (zero? (system* "make" + (string-append "prefix=" out) + "install")))) + ,scotch-phases)))))) + (synopsis "Programs and libraries for graph algorithms (with MPI)"))) -- cgit v1.2.3 From a54aefead6bfcc35bce0ac2aebb4cd32eb94208e Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Mon, 19 May 2014 00:12:46 -0500 Subject: gnu: Add superlu-dist package. * gnu/packages/maths.scm (superlu-dist): New variable. * gnu/packages/patches/superlu-dist-scotchmetis.patch: New patch. * gnu-system.am (dist_patch_DATA): Add it. --- gnu-system.am | 1 + gnu/packages/maths.scm | 101 +++++++++++++++++++++ .../patches/superlu-dist-scotchmetis.patch | 21 +++++ 3 files changed, 123 insertions(+) create mode 100644 gnu/packages/patches/superlu-dist-scotchmetis.patch diff --git a/gnu-system.am b/gnu-system.am index 829c9979e5..36462924c9 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -346,6 +346,7 @@ dist_patch_DATA = \ gnu/packages/patches/soprano-find-clucene.patch \ gnu/packages/patches/source-highlight-regexrange-test.patch \ gnu/packages/patches/sqlite-large-page-size-fix.patch \ + gnu/packages/patches/superlu-dist-scotchmetis.patch \ gnu/packages/patches/tcsh-fix-autotest.patch \ gnu/packages/patches/teckit-cstdio.patch \ gnu/packages/patches/valgrind-glibc.patch \ diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 9288ba91f4..cda3af8d97 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -590,6 +590,107 @@ triangular system solves through forward and back substitution. The library also provides threshold-based ILU factorization preconditioners.") (license license:bsd-3))) +(define-public superlu-dist + (package + (name "superlu-dist") + (version "3.3") + (source + (origin + (method url-fetch) + (uri (string-append "http://crd-legacy.lbl.gov/~xiaoye/SuperLU/" + "superlu_dist_" version ".tar.gz")) + (sha256 + (base32 "1hnak09yxxp026blq8zhrl7685yip16svwngh1wysqxf8z48vzfj")) + (patches (list (search-patch "superlu-dist-scotchmetis.patch"))))) + (build-system gnu-build-system) + (native-inputs + `(("tcsh" ,tcsh))) + (inputs + `(("gfortran" ,gfortran-4.8))) + (propagated-inputs + `(("openmpi" ,openmpi) ;headers include MPI heades + ("lapack" ,lapack) ;required to link with output library + ("pt-scotch" ,pt-scotch))) ;same + (arguments + `(#:parallel-build? #f ;race conditions using ar + #:phases + (alist-replace + 'configure + (lambda* (#:key inputs outputs #:allow-other-keys) + (call-with-output-file "make.inc" + (lambda (port) + (format port " +PLAT = +DSuperLUroot = ~a +DSUPERLULIB = ~a/lib/libsuperlu_dist.a +BLASDEF = -DUSE_VENDOR_BLAS +BLASLIB = -L~a/lib -lblas +PARMETISLIB = -L~a/lib \ + -lptscotchparmetis -lptscotch -lptscotcherr -lptscotcherrexit \ + -lscotch -lscotcherr -lscotcherrexit +METISLIB = -L~:*~a/lib \ + -lscotchmetis -lscotch -lscotcherr -lscotcherrexit +LIBS = $(DSUPERLULIB) $(PARMETISLIB) $(METISLIB) $(BLASLIB) +ARCH = ar +ARCHFLAGS = cr +RANLIB = ranlib +CC = mpicc +PIC = -fPIC +CFLAGS = -O3 -g -DPRNTlevel=0 $(PIC) +NOOPTS = -O0 -g $(PIC) +FORTRAN = mpifort +FFLAGS = -O2 -g $(PIC) +LOADER = $(CC) +CDEFS = -DAdd_" + (getcwd) + (assoc-ref outputs "out") + (assoc-ref inputs "lapack") + (assoc-ref inputs "pt-scotch"))))) + (alist-cons-after + 'unpack 'remove-broken-symlinks + (lambda _ + (for-each delete-file + (find-files "MAKE_INC" "\\.#make\\..*"))) + (alist-cons-before + 'build 'create-install-directories + (lambda* (#:key outputs #:allow-other-keys) + (for-each + (lambda (dir) + (mkdir-p (string-append (assoc-ref outputs "out") + "/" dir))) + '("lib" "include"))) + (alist-replace + 'check + (lambda _ + (with-directory-excursion "EXAMPLE" + (and + (zero? (system* "mpirun" "-n" "2" + "./pddrive" "-r" "1" "-c" "2" "g20.rua")) + (zero? (system* "mpirun" "-n" "2" + "./pzdrive" "-r" "1" "-c" "2" "cg20.cua"))))) + (alist-replace + 'install + (lambda* (#:key outputs #:allow-other-keys) + ;; Library is placed in lib during the build phase. Copy over + ;; headers to include. + (let* ((out (assoc-ref outputs "out")) + (incdir (string-append out "/include"))) + (for-each (lambda (file) + (let ((base (basename file))) + (format #t "installing `~a' to `~a'~%" + base incdir) + (copy-file file + (string-append incdir "/" base)))) + (find-files "SRC" ".*\\.h$")))) + %standard-phases))))))) + (home-page (package-home-page superlu)) + (synopsis "Parallel supernodal direct solver") + (description + "SuperLU_DIST is a parallel extension to the serial SuperLU library. +It is targeted for distributed memory parallel machines. SuperLU_DIST is +implemented in ANSI C, and MPI for communications.") + (license license:bsd-3))) + (define-public scotch (package (name "scotch") diff --git a/gnu/packages/patches/superlu-dist-scotchmetis.patch b/gnu/packages/patches/superlu-dist-scotchmetis.patch new file mode 100644 index 0000000000..3d78380551 --- /dev/null +++ b/gnu/packages/patches/superlu-dist-scotchmetis.patch @@ -0,0 +1,21 @@ +The METIS interface from Scotch may segfault if passed NULL to indicate a +default parameter, so use the older calling style. + +--- a/SRC/get_perm_c.c 2014-05-16 23:38:30.070835316 -0500 ++++ b/SRC/get_perm_c.c 2014-05-16 23:39:04.582836211 -0500 +@@ -70,11 +70,13 @@ + #else + + /* Earlier version 3.x.x */ +- /* METIS_NodeND(&nm, b_colptr, b_rowind, &numflag, metis_options, +- perm, iperm);*/ ++ METIS_NodeND(&nm, b_colptr, b_rowind, &numflag, metis_options, ++ perm, iperm); + + /* Latest version 4.x.x */ ++#if 0 + METIS_NodeND(&nm, b_colptr, b_rowind, NULL, NULL, perm, iperm); ++#endif + + /*check_perm_dist("metis perm", n, perm);*/ + #endif -- cgit v1.2.3 From e38e18ff010e53a788cec30f25ee3d59341b0708 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:00:46 +0200 Subject: vm: Make the device name a parameter. * guix/build/vm.scm (initialize-partition-table): Honor 'device' parameter. (initialize-hard-disk): Add 'device' parameter and honor it. * gnu/system/vm.scm (qemu-image): Adjust accordingly. --- gnu/system/vm.scm | 3 ++- guix/build/vm.scm | 18 +++++++++++------- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 4bf0e06081..ee9ac81ce7 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -230,7 +230,8 @@ the image." (let ((graphs '#$(match inputs (((names . _) ...) names)))) - (initialize-hard-disk #:grub.cfg #$grub-configuration + (initialize-hard-disk "/dev/sda" + #:grub.cfg #$grub-configuration #:closures graphs #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? diff --git a/guix/build/vm.scm b/guix/build/vm.scm index e67b431b5a..cf661a33f3 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -121,7 +121,7 @@ The data at PORT is the format produced by #:references-graphs." "Create on DEVICE a partition table of type LABEL-TYPE, with a single partition of PARTITION-SIZE MiB. Return #t on success." (display "creating partition table...\n") - (zero? (system* "parted" "/dev/sda" "mklabel" label-type + (zero? (system* "parted" device "mklabel" label-type "mkpart" "primary" "ext2" "1MiB" (format #f "~aB" partition-size)))) @@ -147,7 +147,8 @@ REFERENCE-GRAPHS, a list of reference-graph files." (define MS_BIND 4096) ; again! -(define* (initialize-hard-disk #:key +(define* (initialize-hard-disk device + #:key grub.cfg disk-image-size (file-system-type "ext4") @@ -155,7 +156,7 @@ REFERENCE-GRAPHS, a list of reference-graph files." copy-closures? (register-closures? #t) (directives '())) - "Initialize /dev/sda, a disk of DISK-IMAGE-SIZE bytes, with a + "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is true, copy all of CLOSURES to the partition. Lastly, apply DIRECTIVES to @@ -166,19 +167,22 @@ further populate the partition." (define target-store (string-append target-directory (%store-directory))) - (unless (initialize-partition-table "/dev/sda" + (define partition + (string-append device 1)) + + (unless (initialize-partition-table device #:partition-size (- disk-image-size (* 5 (expt 2 20)))) (error "failed to create partition table")) (format #t "creating ~a partition...\n" file-system-type) (unless (zero? (system* (string-append "mkfs." file-system-type) - "-F" "/dev/sda1")) + "-F" partition)) (error "failed to create partition")) (display "mounting partition...\n") (mkdir target-directory) - (mount "/dev/sda1" target-directory file-system-type) + (mount partition target-directory file-system-type) (when copy-closures? ;; Populate the store. @@ -208,7 +212,7 @@ further populate the partition." (display "populating...\n") (populate-root-file-system target-directory) - (unless (install-grub grub.cfg "/dev/sda" target-directory) + (unless (install-grub grub.cfg device target-directory) (error "failed to install GRUB")) ;; 'guix-register' resets timestamps and everything, so no need to do it -- cgit v1.2.3 From c79d54fe41b0a85c76b11ab2643895de2823d477 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:36:15 +0200 Subject: guix system: 'guix system init' installs GRUB by default. * guix/scripts/system.scm (install): Add #:grub?, #:grub.cfg, and #:device parameters; honor them. (show-help): Document '--no-grub'. (%options): Add '--no-grub'. (%default-options): Add 'install-grub?'. (guix-system): Honor 'install-grub?' option from OPTS. Adjust 'install' call accordingly. * doc/guix.texi (Invoking guix system): Document '--no-grub'. --- doc/guix.texi | 3 ++ guix/scripts/system.scm | 86 +++++++++++++++++++++++++++++++++---------------- 2 files changed, 61 insertions(+), 28 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 4c32df3c9f..917be1fc4d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3224,6 +3224,9 @@ files, packages, and so on. It also creates other essential files needed for the system to operate correctly---e.g., the @file{/etc}, @file{/var}, and @file{/run} directories, and the @file{/bin/sh} file. +This command also installs GRUB on the device specified in +@file{my-os-config}, unless the @option{--no-grub} option was passed. + @item vm @cindex virtual machine Build a virtual machine that contain the operating system declared in diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index ee5df6e951..c02ad36c09 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -29,6 +29,8 @@ #:use-module (guix build install) #:use-module (gnu system) #:use-module (gnu system vm) + #:use-module (gnu system grub) + #:use-module (gnu packages grub) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) @@ -69,9 +71,12 @@ file args)))))) (define* (install store os-dir target - #:key (log-port (current-output-port))) + #:key (log-port (current-output-port)) + grub? grub.cfg device) "Copy OS-DIR and its dependencies to directory TARGET. TARGET must be an -absolute directory name since that's what 'guix-register' expects." +absolute directory name since that's what 'guix-register' expects. + +When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." (define to-copy (let ((lst (delete-duplicates (cons os-dir (references store os-dir)) string=?))) @@ -97,8 +102,9 @@ absolute directory name since that's what 'guix-register' expects." (format log-port "populating '~a'...~%" target) (populate-root-file-system target) - ;; TODO: Install GRUB. - ) + (when grub? + (unless (install-grub grub.cfg device target) + (leave (_ "failed to install GRUB on device '~a'~%") device)))) ;;; @@ -122,6 +128,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (show-build-options-help) (display (_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) + (display (_ " + --no-grub for 'init', do not install GRUB")) (newline) (display (_ " -h, --help display this help and exit")) @@ -143,6 +151,9 @@ Build the operating system declared in FILE according to ACTION.\n")) (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) result))) + (option '("no-grub") #f #f + (lambda (opt name arg result) + (alist-delete 'install-grub? result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) @@ -155,7 +166,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (build-hook? . #t) (max-silent-time . 3600) (verbosity . 0) - (image-size . ,(* 900 (expt 2 20))))) + (image-size . ,(* 900 (expt 2 20))) + (install-grub? . #t))) ;;; @@ -205,39 +217,57 @@ Build the operating system declared in FILE according to ACTION.\n")) args)) (with-error-handling - (let* ((opts (parse-options)) - (args (option-arguments opts)) - (file (first args)) - (action (assoc-ref opts 'action)) - (os (if file - (read-operating-system file) - (leave (_ "no configuration file specified~%")))) - (mdrv (case action - ((build init) - (operating-system-derivation os)) - ((vm-image) - (let ((size (assoc-ref opts 'image-size))) - (system-qemu-image os - #:disk-image-size size))) - ((vm) - (system-qemu-image/shared-store-script os)))) - (store (open-connection)) - (dry? (assoc-ref opts 'dry-run?)) - (drv (run-with-store store mdrv))) + (let* ((opts (parse-options)) + (args (option-arguments opts)) + (file (first args)) + (action (assoc-ref opts 'action)) + (os (if file + (read-operating-system file) + (leave (_ "no configuration file specified~%")))) + (mdrv (case action + ((build init) + (operating-system-derivation os)) + ((vm-image) + (let ((size (assoc-ref opts 'image-size))) + (system-qemu-image os + #:disk-image-size size))) + ((vm) + (system-qemu-image/shared-store-script os)))) + (store (open-connection)) + (dry? (assoc-ref opts 'dry-run?)) + (drv (run-with-store store mdrv)) + (grub? (assoc-ref opts 'install-grub?)) + (grub.cfg (run-with-store store + (operating-system-grub.cfg os))) + (grub (package-derivation store grub)) + (drv-lst (if grub? + (list drv grub grub.cfg) + (list drv)))) (set-build-options-from-command-line store opts) - (show-what-to-build store (list drv) + (show-what-to-build store drv-lst #:dry-run? dry? #:use-substitutes? (assoc-ref opts 'substitutes?)) (unless dry? - (build-derivations store (list drv)) + (build-derivations store drv-lst) (display (derivation->output-path drv)) (newline) (when (eq? action 'init) - (let ((target (second args))) + (let* ((target (second args)) + (device (grub-configuration-device + (operating-system-bootloader os)))) (format #t (_ "initializing operating system under '~a'...~%") target) + (when grub + (let ((prefix (derivation->output-path grub))) + (setenv "PATH" + (string-append prefix "/bin:" prefix "/sbin:" + (getenv "PATH"))))) + (install store (derivation->output-path drv) - (canonicalize-path target)))))))) + (canonicalize-path target) + #:grub? grub? + #:grub.cfg (derivation->output-path grub.cfg) + #:device device))))))) -- cgit v1.2.3 From d467e640aa763e3440231270c832028b5c804a6a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:38:44 +0200 Subject: doc: Show the 'bootloader' field in system example. * doc/guix.texi (Using the Configuration System): Add 'bootloader' field. --- doc/guix.texi | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 917be1fc4d..57c9e4e52a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3125,6 +3125,8 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this: (host-name "komputilo") (timezone "Europe/Paris") (locale "fr_FR.UTF-8") + (bootloader (grub-configuration + (device "/dev/sda"))) (file-systems (list (file-system (device "/dev/disk/by-label/root") (mount-point "/") -- cgit v1.2.3 From c56d19fb113d96a5af7c6d0500d256e633fe3eb9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:42:34 +0200 Subject: guix system: Factorize out closure copy. * guix/scripts/system.scm (copy-closure): New procedure. (install): Use it. --- guix/scripts/system.scm | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index c02ad36c09..78bff28112 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -70,6 +70,22 @@ (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) +(define* (copy-closure store item target + #:key (log-port (current-error-port))) + "Copy ITEM to the store under root directory TARGET and register it." + (let ((dest (string-append target item)) + (refs (references store item))) + (format log-port "copying '~a'...~%" item) + (copy-recursively item dest + #:log (%make-void-port "w")) + + ;; Register ITEM; as a side-effect, it resets timestamps, etc. + (unless (register-path item + #:prefix target + #:references refs) + (leave (_ "failed to register '~a' under '~a'~%") + item target)))) + (define* (install store os-dir target #:key (log-port (current-output-port)) grub? grub.cfg device) @@ -83,19 +99,7 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." (topologically-sorted store lst))) ;; Copy items to the new store. - (for-each (lambda (item) - (let ((dest (string-append target item)) - (refs (references store item))) - (format log-port "copying '~a'...~%" item) - (copy-recursively item dest - #:log (%make-void-port "w")) - - ;; Register ITEM; as a side-effect, it resets timestamps, etc. - (unless (register-path item - #:prefix target - #:references refs) - (leave (_ "failed to register '~a' under '~a'~%") - item target)))) + (for-each (cut copy-closure store <> target #:log-port log-port) to-copy) ;; Create a bunch of additional files. -- cgit v1.2.3 From 79b0d4e1049afe1ceb5d420a9ceb11c230a1da24 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 22:47:27 +0200 Subject: guix system: Check whether we are installing to /. * guix/scripts/system.scm (install): Check whether TARGET is / and warn. --- guix/scripts/system.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 78bff28112..af48c57b54 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -98,9 +98,11 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." string=?))) (topologically-sorted store lst))) - ;; Copy items to the new store. - (for-each (cut copy-closure store <> target #:log-port log-port) - to-copy) + (if (string=? target "/") + (warning (_ "initializing the current root file system~%")) + ;; Copy items to the new store. + (for-each (cut copy-closure store <> target #:log-port log-port) + to-copy)) ;; Create a bunch of additional files. (format log-port "populating '~a'...~%" target) -- cgit v1.2.3 From 52ddf2ae6fb369ec64aae75fc311d6cc57a713b6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 23:08:43 +0200 Subject: ui: Gracefully deal with zero-output derivations. * guix/ui.scm (show-what-to-build)[built-or-substitutable?]: New procedure. Check whether OUT is #f. Use it. * tests/ui.scm ("show-what-to-build, zero outputs"): New test. --- guix/ui.scm | 17 +++++++++-------- tests/ui.scm | 12 ++++++++++++ 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/guix/ui.scm b/guix/ui.scm index 259dddd481..48b5c745c6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -261,6 +261,14 @@ error." derivations listed in DRV. Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are available for download." + (define (built-or-substitutable? drv) + (let ((out (derivation->output-path drv))) + ;; If DRV has zero outputs, OUT is #f. + (or (not out) + (or (valid-path? store out) + (and use-substitutes? + (has-substitutes? store out)))))) + (let*-values (((build download) (fold2 (lambda (drv build download) (let-values (((b d) @@ -275,14 +283,7 @@ available for download." ((build) ; add the DRV themselves (delete-duplicates (append (map derivation-file-name - (remove (lambda (drv) - (let ((out (derivation->output-path - drv))) - (or (valid-path? store out) - (and use-substitutes? - (has-substitutes? store - out))))) - drv)) + (remove built-or-substitutable? drv)) (map derivation-input-path build)))) ((download) ; add the references of DOWNLOAD (if use-substitutes? diff --git a/tests/ui.scm b/tests/ui.scm index 886223ef54..4bf7a779c5 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -19,6 +19,8 @@ (define-module (test-ui) #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-64)) @@ -189,6 +191,16 @@ interface, and powerful string processing.") (lambda args #t))) +(test-equal "show-what-to-build, zero outputs" + "" + (with-store store + (let ((drv (derivation store "zero" "/bin/sh" '() + #:outputs '()))) + (with-error-to-string + (lambda () + ;; This should print nothing. + (show-what-to-build store (list drv))))))) + (test-end "ui") -- cgit v1.2.3 From b10e9ff6da886a787e37c3bf34da9e80406ae14b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 May 2014 23:52:11 +0200 Subject: gnu: Add Linux kbd. * gnu/packages/linux.scm (kbd): New variable. --- gnu/packages/linux.scm | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index bcef394244..e9e7ebb99c 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -39,6 +39,7 @@ #:use-module (gnu packages xml) #:use-module (gnu packages autotools) #:use-module (gnu packages texinfo) + #:use-module (gnu packages check) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) @@ -1087,3 +1088,40 @@ The numademo command provides a quick overview of NUMA performance on your system.") (license (list gpl2 ; programs lgpl2.1)))) ; library + +(define-public kbd + (package + (name "kbd") + (version "2.0.1") + (source (origin + (method url-fetch) + (uri (string-append "mirror://kernel.org/linux/utils/kbd/kbd-" + version ".tar.gz")) + (sha256 + (base32 + "0c34b0za2v0934acvgnva0vaqpghmmhz4zh7k0m9jd4mbc91byqm")))) + (build-system gnu-build-system) + (arguments + '(#:phases (alist-cons-before + 'build 'pre-build + (lambda* (#:key inputs #:allow-other-keys) + (let ((gzip (assoc-ref %build-inputs "gzip")) + (bzip2 (assoc-ref %build-inputs "bzip2"))) + (substitute* "src/libkeymap/findfile.c" + (("gzip") + (string-append gzip "/bin/gzip")) + (("bzip2") + (string-append bzip2 "/bin/bzip2"))))) + %standard-phases))) + (inputs `(("check" ,check) + ("gzip" ,guix:gzip) + ("bzip2" ,guix:bzip2) + ("pam" ,linux-pam))) + (native-inputs `(("pkg-config" ,pkg-config))) + (home-page "ftp://ftp.kernel.org/pub/linux/utils/kbd/") + (synopsis "Linux keyboard utilities and keyboard maps") + (description + "This package contains keytable files and keyboard utilities compatible +for systems using the Linux kernel. This includes commands such as +'loadkeys', 'setfont', 'kbdinfo', and 'chvt'.") + (license gpl2+))) -- cgit v1.2.3 From 3919a31a75f4de5c88decff60f9be737a36e626c Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 20 May 2014 09:00:04 -0500 Subject: gnu: Add offlineimap * gnu/packages/mail.scm (offlineimap): New variable. --- gnu/packages/mail.scm | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/gnu/packages/mail.scm b/gnu/packages/mail.scm index 3790b583ee..1ba75da02b 100644 --- a/gnu/packages/mail.scm +++ b/gnu/packages/mail.scm @@ -32,6 +32,7 @@ #:use-module (gnu packages ncurses) #:use-module (gnu packages openssl) #:use-module (gnu packages perl) + #:use-module (gnu packages python) #:use-module (gnu packages readline) #:use-module (gnu packages texinfo) #:use-module (gnu packages compression) @@ -44,6 +45,7 @@ #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) + #:use-module (guix build-system python) #:use-module (srfi srfi-1)) (define-public mailutils @@ -253,4 +255,30 @@ content (body). The program is able to learn from the user's classifications and corrections. It is based on a Bayesian filter.") (license gpl2))) +(define-public offlineimap + (package + (name "offlineimap") + (version "6.5.5") + (source (origin + (method url-fetch) + (uri (string-append "https://github.com/OfflineIMAP/offlineimap/" + "archive/v" version ".tar.gz")) + (sha256 + (base32 + "00k84qagph3xnxss6rkxm61x07ngz8fvffx4z9jyw5baf3cdd32p")))) + (build-system python-build-system) + (native-inputs `(("python" ,python-2))) + (arguments + ;; The setup.py script expects python-2. + `(#:python ,python-2 + ;; Tests require a modifiable IMAP account. + #:tests? #f)) + (home-page "http://www.offlineimap.org") + (synopsis "Synch emails between two repositories") + (description + "OfflineImap synchronizes emails between two repositories, so that you +can read the same mailbox from multiple computers. It supports IMAP as REMOTE +repository and Maildir/IMAP as LOCAL repository.") + (license gpl2))) + ;;; mail.scm ends here -- cgit v1.2.3 From d2938d59aafbb4a65e8c2035a40e878a7fc94d33 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 20 May 2014 09:00:59 -0500 Subject: gnu: Add mu. * gnu/packages/mail.scm (mu): New variable. --- gnu/packages/mail.scm | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/gnu/packages/mail.scm b/gnu/packages/mail.scm index 1ba75da02b..ece06dd0ab 100644 --- a/gnu/packages/mail.scm +++ b/gnu/packages/mail.scm @@ -20,9 +20,12 @@ (define-module (gnu packages mail) #:use-module (gnu packages) #:use-module (gnu packages autotools) + #:use-module (gnu packages base) #:use-module (gnu packages cyrus-sasl) #:use-module (gnu packages dejagnu) + #:use-module (gnu packages emacs) #:use-module (gnu packages gdbm) + #:use-module (gnu packages glib) #:use-module (gnu packages gnupg) #:use-module (gnu packages gnutls) #:use-module (gnu packages guile) @@ -34,6 +37,7 @@ #:use-module (gnu packages perl) #:use-module (gnu packages python) #:use-module (gnu packages readline) + #:use-module (gnu packages search) #:use-module (gnu packages texinfo) #:use-module (gnu packages compression) #:use-module (gnu packages glib) @@ -281,4 +285,45 @@ can read the same mailbox from multiple computers. It supports IMAP as REMOTE repository and Maildir/IMAP as LOCAL repository.") (license gpl2))) +(define-public mu + (package + (name "mu") + (version "0.9.9.5") + (source (origin + (method url-fetch) + (uri (string-append "https://mu0.googlecode.com/files/mu-" + version ".tar.gz")) + (sha256 + (base32 + "1hwkliyb8fjrz5sw9fcisssig0jkdxzhccw0ld0l9a10q1l9mqhp")))) + (build-system gnu-build-system) + (native-inputs + `(("pkg-config" ,pkg-config) + ("texinfo" ,texinfo))) + ;; TODO: Add webkit and gtk to build the mug GUI. + (inputs + `(("xapian" ,xapian) + ("emacs" ,emacs) + ("guile" ,guile-2.0) + ("glib" ,glib) + ("gmime" ,gmime) + ("tzdata" ,tzdata))) ;for mu/test/test-mu-query.c + (arguments + '(#:phases (alist-cons-before + 'check 'check-tz-setup + (lambda* (#:key inputs #:allow-other-keys) + ;; For mu/test/test-mu-query.c + (setenv "TZDIR" + (string-append (assoc-ref inputs "tzdata") + "/share/zoneinfo"))) + %standard-phases))) + (home-page "http://www.djcbsoftware.nl/code/mu/") + (synopsis "Quickly find emails") + (description + "Mu is a tool for dealing with e-mail messages stored in the +Maildir-format. Mu's purpose in life is to help you to quickly find the +messages you need; in addition, it allows you to view messages, extract +attachments, create new maildirs, and so on.") + (license gpl3+))) + ;;; mail.scm ends here -- cgit v1.2.3 From 7886e23b03881a2d11bc97a05c4a77d04cf2c8f5 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 20 May 2014 09:50:58 -0500 Subject: gnu: offlineimap: fix license. * gnu/packages/mail.scm (offlineimap) [license]: Change to gpl2+. --- gnu/packages/mail.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnu/packages/mail.scm b/gnu/packages/mail.scm index ece06dd0ab..796dcd7e88 100644 --- a/gnu/packages/mail.scm +++ b/gnu/packages/mail.scm @@ -283,7 +283,7 @@ and corrections. It is based on a Bayesian filter.") "OfflineImap synchronizes emails between two repositories, so that you can read the same mailbox from multiple computers. It supports IMAP as REMOTE repository and Maildir/IMAP as LOCAL repository.") - (license gpl2))) + (license gpl2+))) (define-public mu (package -- cgit v1.2.3 From 16ecf3ff4a06b35c2f74325606e915c782ef2549 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Sat, 17 May 2014 01:44:42 -0500 Subject: gnu: Edit synopses of petsc packages. * gnu/packages/maths.scm (petsc) [synopsis]: Shorten. (petsc-complex,petsc-openmpi,petsc-complex-openmpi) [synopsis]: Repeat synopsis from petsc package with extensions. [description]: Remove. --- gnu/packages/maths.scm | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index cda3af8d97..4fcb997f34 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -456,7 +456,7 @@ ASCII text files using Gmsh's own scripting language.") "conf/uninstall.py")))) %standard-phases))))) (home-page "http://www.mcs.anl.gov/petsc") - (synopsis "Library to solve ODEs and algebraic equations") + (synopsis "Library to solve PDEs") (description "PETSc, pronounced PET-see (the S is silent), is a suite of data structures and routines for the scalable (parallel) solution of scientific applications modeled by partial differential equations.") @@ -470,9 +470,7 @@ scientific applications modeled by partial differential equations.") (substitute-keyword-arguments (package-arguments petsc) ((#:configure-flags cf) `(cons "--with-scalar-type=complex" ,cf)))) - (description - (string-append (package-description petsc) - " Complex scalar type version.")))) + (synopsis "Library to solve PDEs (with complex scalars)"))) (define-public petsc-openmpi (package (inherit petsc) @@ -487,9 +485,7 @@ scientific applications modeled by partial differential equations.") ,(string-append "--with-mpi-dir=" (assoc-ref %build-inputs "openmpi")) ,@(delete "--with-mpi=0" ,cf))))) - (description - (string-append (package-description petsc) - " With OpenMPI parallelism support.")))) + (synopsis "Library to solve PDEs (with MPI support)"))) (define-public petsc-complex-openmpi (package (inherit petsc-complex) @@ -504,9 +500,7 @@ scientific applications modeled by partial differential equations.") ,(string-append "--with-mpi-dir=" (assoc-ref %build-inputs "openmpi")) ,@(delete "--with-mpi=0" ,cf))))) - (description - (string-append (package-description petsc-complex) - " With OpenMPI parallelism support.")))) + (synopsis "Library to solve PDEs (with complex scalars and MPI support)"))) (define-public superlu (package -- cgit v1.2.3 From 5bbd6bf1815398f3cbe3d2f218b537a82f7219a7 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 20 May 2014 12:20:12 -0500 Subject: gnu: Add ccache. * gnu/packages/ccache.scm: New file. * gnu/packages/patches/ccache-stdc-predef-test.patch: New patch. * gnu-system.am (GNU_SYSTEM_MODULES): Add ccache.scm. (dist_patch_DATA): Add patch. --- gnu-system.am | 2 + gnu/packages/ccache.scm | 57 ++++++++ gnu/packages/patches/ccache-stdc-predef-test.patch | 157 +++++++++++++++++++++ 3 files changed, 216 insertions(+) create mode 100644 gnu/packages/ccache.scm create mode 100644 gnu/packages/patches/ccache-stdc-predef-test.patch diff --git a/gnu-system.am b/gnu-system.am index 36462924c9..66d54cba95 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -43,6 +43,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/boost.scm \ gnu/packages/bootstrap.scm \ gnu/packages/calcurse.scm \ + gnu/packages/ccache.scm \ gnu/packages/cdrom.scm \ gnu/packages/cflow.scm \ gnu/packages/check.scm \ @@ -264,6 +265,7 @@ dist_patch_DATA = \ gnu/packages/patches/binutils-loongson-workaround.patch \ gnu/packages/patches/bitlbee-fix-tests.patch \ gnu/packages/patches/bitlbee-memset-fix.patch \ + gnu/packages/patches/ccache-stdc-predef-test.patch \ gnu/packages/patches/cdparanoia-fpic.patch \ gnu/packages/patches/clucene-pkgconfig.patch \ gnu/packages/patches/cmake-fix-tests.patch \ diff --git a/gnu/packages/ccache.scm b/gnu/packages/ccache.scm new file mode 100644 index 0000000000..4918ec9609 --- /dev/null +++ b/gnu/packages/ccache.scm @@ -0,0 +1,57 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier +;;; +;;; 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 . + +(define-module (gnu packages ccache) + #:use-module (guix packages) + #:use-module ((guix licenses) #:select (gpl3+)) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module (gnu packages) + #:use-module (gnu packages perl) + #:use-module (gnu packages compression)) + +(define-public ccache + (package + (name "ccache") + (version "3.1.9") + (source + (origin + (method url-fetch) + (uri (string-append "https://www.samba.org/ftp/ccache/ccache-" + version ".tar.xz")) + (sha256 + (base32 + "1i06015jjc0n55xgvhv2h37fjp0i7z8a10s0v40f87c5mprzv0a9")) + (patches (list (search-patch "ccache-stdc-predef-test.patch"))))) + (build-system gnu-build-system) + (native-inputs `(("perl" ,perl))) ;for test.sh + (inputs `(("zlib" ,zlib))) + (arguments + '(#:phases (alist-cons-before + 'check 'patch-test-shebangs + (lambda _ + (substitute* '("test/test_hashutil.c" "test.sh") + (("#!/bin/sh") (string-append "#!" (which "sh"))))) + %standard-phases))) + (home-page "https://ccache.samba.org/") + (synopsis "Compiler cache") + (description + "Ccache is a compiler cache. It speeds up recompilation by caching +previous compilations and detecting when the same compilation is being done +again. Supported languages are C, C++, Objective-C and Objective-C++.") + (license gpl3+))) diff --git a/gnu/packages/patches/ccache-stdc-predef-test.patch b/gnu/packages/patches/ccache-stdc-predef-test.patch new file mode 100644 index 0000000000..bd9444c2df --- /dev/null +++ b/gnu/packages/patches/ccache-stdc-predef-test.patch @@ -0,0 +1,157 @@ +This patch is a combination of the following commits:: + + https://git.samba.org/?p=ccache.git;a=commit;h=b5d63f81c1a83fd4c50b769a96a04f581b7db70c + https://git.samba.org/?p=ccache.git;a=commit;h=a11f5688748ecb49f590b3f4bc0e9b3458f9a56f + https://git.samba.org/?p=ccache.git;a=commit;h=5a9322c56ed0cd16255966e99077843aae57ab3e + +from the general discussion at +http://comments.gmane.org/gmane.comp.compilers.ccache/1089 + +--- a/test.sh ++++ b/test.sh +@@ -562,6 +562,12 @@ + EOF + backdate test1.h test2.h test3.h + ++ $COMPILER -c -Wp,-MD,expected.d test.c ++ expected_d_content=`cat expected.d` ++ ++ $COMPILER -c -Wp,-MMD,expected_mmd.d test.c ++ expected_mmd_d_content=`cat expected_mmd.d` ++ + ################################################################## + # First compilation is a miss. + testname="first compilation" +@@ -677,7 +683,7 @@ + checkstat 'cache hit (direct)' 0 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile other.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile other.d "$expected_d_content" + + rm -f other.d + +@@ -685,7 +691,7 @@ + checkstat 'cache hit (direct)' 1 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile other.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile other.d "$expected_d_content" + + rm -f other.d + +@@ -698,7 +704,7 @@ + checkstat 'cache hit (direct)' 0 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile other.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile other.d "$expected_mmd_d_content" + + rm -f other.d + +@@ -706,7 +712,7 @@ + checkstat 'cache hit (direct)' 1 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile other.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile other.d "$expected_mmd_d_content" + + rm -f other.d + +@@ -760,7 +766,7 @@ + checkstat 'cache hit (direct)' 0 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile test.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile test.d "$expected_d_content" + + rm -f test.d + +@@ -768,7 +774,7 @@ + checkstat 'cache hit (direct)' 1 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile test.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile test.d "$expected_d_content" + + ################################################################## + # Check the scenario of running a ccache with direct mode on a cache +@@ -780,7 +786,7 @@ + checkstat 'cache hit (direct)' 0 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile test.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile test.d "$expected_d_content" + + rm -f test.d + +@@ -788,7 +794,7 @@ + checkstat 'cache hit (direct)' 0 + checkstat 'cache hit (preprocessed)' 1 + checkstat 'cache miss' 1 +- checkfile test.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile test.d "$expected_d_content" + + rm -f test.d + +@@ -796,7 +802,7 @@ + checkstat 'cache hit (direct)' 0 + checkstat 'cache hit (preprocessed)' 2 + checkstat 'cache miss' 1 +- checkfile test.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile test.d "$expected_d_content" + + rm -f test.d + +@@ -804,7 +810,7 @@ + checkstat 'cache hit (direct)' 1 + checkstat 'cache hit (preprocessed)' 2 + checkstat 'cache miss' 1 +- checkfile test.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile test.d "$expected_d_content" + + ################################################################## + # Check that -MF works. +@@ -815,7 +821,7 @@ + checkstat 'cache hit (direct)' 0 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile other.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile other.d "$expected_d_content" + + rm -f other.d + +@@ -823,7 +829,7 @@ + checkstat 'cache hit (direct)' 1 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile other.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile other.d "$expected_d_content" + + ################################################################## + # Check that a missing .d file in the cache is handled correctly. +@@ -835,13 +841,13 @@ + checkstat 'cache hit (direct)' 0 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile other.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile other.d "$expected_d_content" + + $CCACHE $COMPILER -c -MD test.c + checkstat 'cache hit (direct)' 1 + checkstat 'cache hit (preprocessed)' 0 + checkstat 'cache miss' 1 +- checkfile other.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile other.d "$expected_d_content" + + find $CCACHE_DIR -name '*.d' -exec rm -f '{}' \; + +@@ -849,7 +855,7 @@ + checkstat 'cache hit (direct)' 1 + checkstat 'cache hit (preprocessed)' 1 + checkstat 'cache miss' 1 +- checkfile other.d "test.o: test.c test1.h test3.h test2.h" ++ checkfile other.d "$expected_d_content" + + ################################################################## + # Check that stderr from both the preprocessor and the compiler is emitted -- cgit v1.2.3 From 9bea3b42b49434bccd9acd296569d2a874eddb6e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 21:52:31 +0200 Subject: vm: Fix typo. Regression introduced in e38e18f. * guix/build/vm.scm (initialize-hard-disk)[partition]: Use a string. --- guix/build/vm.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/guix/build/vm.scm b/guix/build/vm.scm index cf661a33f3..e3f6d27ee7 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -168,7 +168,7 @@ further populate the partition." (string-append target-directory (%store-directory))) (define partition - (string-append device 1)) + (string-append device "1")) (unless (initialize-partition-table device #:partition-size -- cgit v1.2.3 From eb7ccb1afaaa5db3a6c4fdec0a9f22919d100952 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 21:56:20 +0200 Subject: linux-initrd: Display a backtrace when the initial program fails. * guix/build/linux-initrd.scm (boot-system): Add pre-unwind handler in 'catch' form around 'primitive-load', and call 'format' and 'display-backtrace' from there. --- guix/build/linux-initrd.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 9093e72695..8db9f02caf 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -482,10 +482,12 @@ to it are lost." (catch #t (lambda () (primitive-load to-load)) + (lambda args + (start-repl)) (lambda args (format (current-error-port) "'~a' raised an exception: ~s~%" to-load args) - (start-repl))) + (display-backtrace (make-stack #t) (current-error-port)))) (format (current-error-port) "boot program '~a' terminated, rebooting~%" to-load) -- cgit v1.2.3 From c5df183956016cf3205971f4fa30aa834dca3281 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 21:59:08 +0200 Subject: Add (gnu system file-systems). This fixes a circular dependency between (gnu system) and (gnu system linux-initrd), where the latter could end up being compiled before 'file-system-type' was defined as a macro. * gnu/system.scm (, %fuse-control-file-system, %binary-format-file-system): Move to... * gnu/system/file-systems.scm: ... here. New file. * build-aux/hydra/demo-os.scm, gnu/system/linux-initrd.scm, gnu/system/vm.scm: Use it. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. --- build-aux/hydra/demo-os.scm | 2 ++ gnu-system.am | 1 + gnu/system.scm | 53 ++------------------------------- gnu/system/file-systems.scm | 72 +++++++++++++++++++++++++++++++++++++++++++++ gnu/system/linux-initrd.scm | 2 +- gnu/system/vm.scm | 1 + 6 files changed, 79 insertions(+), 52 deletions(-) create mode 100644 gnu/system/file-systems.scm diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index fe9c77242e..5f0fd6a6f8 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -36,6 +36,8 @@ (gnu system grub) ; 'grub-configuration' (gnu system shadow) ; 'user-account' (gnu system linux) ; 'base-pam-services' + (gnu system file-systems) ; 'file-systems' + (gnu services base) (gnu services networking) (gnu services xorg)) diff --git a/gnu-system.am b/gnu-system.am index 66d54cba95..84a5e939f4 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -248,6 +248,7 @@ GNU_SYSTEM_MODULES = \ gnu/services/xorg.scm \ \ gnu/system.scm \ + gnu/system/file-systems.scm \ gnu/system/grub.scm \ gnu/system/linux.scm \ gnu/system/linux-initrd.scm \ diff --git a/gnu/system.scm b/gnu/system.scm index dd44878462..6cb7d303db 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -34,6 +34,7 @@ #:use-module (gnu system shadow) #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) + #:use-module (gnu system file-systems) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -56,20 +57,7 @@ operating-system-derivation operating-system-profile - operating-system-grub.cfg - - - file-system - file-system? - file-system-device - file-system-mount-point - file-system-type - file-system-needed-for-boot? - file-system-flags - file-system-options - - %fuse-control-file-system - %binary-format-file-system)) + operating-system-grub.cfg)) ;;; Commentary: ;;; @@ -129,43 +117,6 @@ (sudoers operating-system-sudoers ; /etc/sudoers contents (default %sudoers-specification))) - -;;; -;;; File systems. -;;; - -;; File system declaration. -(define-record-type* file-system - make-file-system - file-system? - (device file-system-device) ; string - (mount-point file-system-mount-point) ; string - (type file-system-type) ; string - (flags file-system-flags ; list of symbols - (default '())) - (options file-system-options ; string or #f - (default #f)) - (needed-for-boot? file-system-needed-for-boot? ; Boolean - (default #f)) - (check? file-system-check? ; Boolean - (default #t))) - -(define %fuse-control-file-system - ;; Control file system for Linux' file systems in user-space (FUSE). - (file-system - (device "fusectl") - (mount-point "/sys/fs/fuse/connections") - (type "fusectl") - (check? #f))) - -(define %binary-format-file-system - ;; Support for arbitrary executable binary format. - (file-system - (device "binfmt_misc") - (mount-point "/proc/sys/fs/binfmt_misc") - (type "binfmt_misc") - (check? #f))) - ;;; ;;; Derivation. diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm new file mode 100644 index 0000000000..485150ea51 --- /dev/null +++ b/gnu/system/file-systems.scm @@ -0,0 +1,72 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu system file-systems) + #:use-module (guix records) + #:export ( + file-system + file-system? + file-system-device + file-system-mount-point + file-system-type + file-system-needed-for-boot? + file-system-flags + file-system-options + + %fuse-control-file-system + %binary-format-file-system)) + +;;; Commentary: +;;; +;;; Declaring file systems to be mounted. +;;; +;;; Code: + +;; File system declaration. +(define-record-type* file-system + make-file-system + file-system? + (device file-system-device) ; string + (mount-point file-system-mount-point) ; string + (type file-system-type) ; string + (flags file-system-flags ; list of symbols + (default '())) + (options file-system-options ; string or #f + (default #f)) + (needed-for-boot? file-system-needed-for-boot? ; Boolean + (default #f)) + (check? file-system-check? ; Boolean + (default #t))) + +(define %fuse-control-file-system + ;; Control file system for Linux' file systems in user-space (FUSE). + (file-system + (device "fusectl") + (mount-point "/sys/fs/fuse/connections") + (type "fusectl") + (check? #f))) + +(define %binary-format-file-system + ;; Support for arbitrary executable binary format. + (file-system + (device "binfmt_misc") + (mount-point "/proc/sys/fs/binfmt_misc") + (type "binfmt_misc") + (check? #f))) + +;;; file-systems.scm ends here diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 749dfa313f..03199e0c39 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -30,7 +30,7 @@ #:use-module (gnu packages guile) #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) - #:use-module (gnu system) ; for 'file-system' + #:use-module (gnu system file-systems) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index ee9ac81ce7..0d41791d87 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -42,6 +42,7 @@ #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) #:use-module (gnu system grub) + #:use-module (gnu system file-systems) #:use-module (gnu system) #:use-module (gnu services) -- cgit v1.2.3 From 29decd1f368e769ac176822c0b5e0d54e056b7d2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 23:18:02 +0200 Subject: Augment (guix). * guix.scm (%public-modules): Add 'monads' and 'gexp'. --- guix.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/guix.scm b/guix.scm index 1b7fd0c5a2..706ea29065 100644 --- a/guix.scm +++ b/guix.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès +;;; Copyright © 2012, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,8 +26,10 @@ '(base32 build-system derivations - ftp-client download + ftp-client + gexp + monads packages store utils)) -- cgit v1.2.3 From d28869afadd37757aca79c0f6272b962e2083e32 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 May 2014 15:29:23 +0200 Subject: store: Flush the output when the build process emits '\r'. This allows progress reports emitted by 'substitute-binary' to be correctly displayed. * guix/store.scm (%newlines): New variable. (process-stderr) <%stderr-next>: Flush (current-build-output-port) when S contains one of %NEWLINES. --- guix/store.scm | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/guix/store.scm b/guix/store.scm index 073e024e38..864303ddb3 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -370,6 +370,12 @@ to OUT, using chunks of BUFFER-SIZE bytes." (min (- len total) buffer-size) buffer-size))))))) +(define %newlines + ;; Newline characters triggering a flush of 'current-build-output-port'. + ;; Unlike Guile's _IOLBF, we flush upon #\return so that progress reports + ;; that use that trick are correctly displayed. + (char-set #\newline #\return)) + (define* (process-stderr server #:optional user-port) "Read standard output and standard error from SERVER, writing it to CURRENT-BUILD-OUTPUT-PORT. Return #t when SERVER is done sending data, and @@ -412,6 +418,8 @@ encoding conversion errors." ;; Log a string. (let ((s (read-latin1-string p))) (display s (current-build-output-port)) + (when (string-any %newlines s) + (flush-output-port (current-build-output-port))) #f)) ((= k %stderr-error) ;; Report an error. -- cgit v1.2.3 From 952298d709b63b6475640e4a777b28f5fbf7cfeb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 May 2014 17:12:03 +0200 Subject: gnu: Add wpa_supplicant. * gnu/packages/admin.scm (wpa-supplicant): New variable. --- gnu/packages/admin.scm | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm index 57fc645ad3..df968c4846 100644 --- a/gnu/packages/admin.scm +++ b/gnu/packages/admin.scm @@ -671,3 +671,63 @@ commands and their arguments.") ;; See . (license x11))) + +(define-public wpa-supplicant + (package + (name "wpa-supplicant") + (version "2.1") + (source (origin + (method url-fetch) + (uri (string-append + "http://hostap.epitest.fi/releases/wpa_supplicant-" + version + ".tar.gz")) + (sha256 + (base32 + "0xxjw7lslvql1ykfbwmbhdrnjsjljf59fbwf837418s97dz2wqwi")))) + (build-system gnu-build-system) + (arguments + '(#:phases (alist-replace + 'configure + (lambda* (#:key outputs #:allow-other-keys) + (chdir "wpa_supplicant") + (copy-file "defconfig" ".config") + (let ((port (open-file ".config" "al"))) + (display " + CONFIG_DEBUG_SYSLOG=y + CONFIG_CTRL_IFACE_DBUS=y + CONFIG_CTRL_IFACE_DBUS_NEW=y + CONFIG_CTRL_IFACE_DBUS_INTRO=y + CONFIG_DRIVER_NL80211=y + CFLAGS += $(shell pkg-config libnl-3.0 --cflags) + CONFIG_LIBNL32=y + CONFIG_READLINE=y\n" port) + (close-port port))) + %standard-phases) + + #:make-flags (list "CC=gcc" + (string-append "BINDIR=" (assoc-ref %outputs "out") + "/sbin") + (string-append "LIBDIR=" (assoc-ref %outputs "out") + "/lib")) + #:tests? #f)) + (inputs + `(("readline" ,readline) + ("libnl" ,libnl) + ("dbus" ,dbus) + ("openssl" ,o:openssl))) + (native-inputs + `(("pkg-config" ,pkg-config))) + (home-page "http://hostap.epitest.fi/wpa_supplicant/") + (synopsis "Connecting to WPA and WPA2-protected wireless networks") + (description + "wpa_supplicant is a WPA Supplicant with support for WPA and WPA2 (IEEE +802.11i / RSN). Supplicant is the IEEE 802.1X/WPA component that is used in +the client stations. It implements key negotiation with a WPA Authenticator +and it controls the roaming and IEEE 802.11 authentication/association of the +WLAN driver. + +This package provides the 'wpa_supplicant' daemon and the 'wpa_cli' command.") + + ;; In practice, this is linked against Readline, which makes it GPLv3+. + (license bsd-3))) -- cgit v1.2.3 From d1f477199d649cbe33558ed218fa8063553decc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 May 2014 23:19:13 +0200 Subject: vm: Remove misleading comment. * guix/build/vm.scm (load-in-linux-vm): Remove misleading comment. --- guix/build/vm.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/guix/build/vm.scm b/guix/build/vm.scm index e3f6d27ee7..3c51ff8f34 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -94,8 +94,7 @@ the #:references-graphs parameter of 'derivation'." (error "qemu failed" qemu)) (if make-disk-image? - (copy-file "image.qcow2" ; XXX: who mkdir'd OUTPUT? - output) + (copy-file "image.qcow2" output) (begin (mkdir output) (copy-recursively "xchg" output)))) -- cgit v1.2.3 From 641f9a2a1f3a1ad0b4c3003a2efc5c7975286cc1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 May 2014 23:31:46 +0200 Subject: vm: Modularize build-side code. * guix/build/install.scm (install-grub): Call 'error' if 'system*' returns non-zero. * guix/build/vm.scm (initialize-partition-table): Make 'partition-size' a positional parameter. Call 'error' when 'system*' returns non-zero'. (format-partition, initialize-root-partition): New procedures. (initialize-hard-disk): Use them. --- guix/build/install.scm | 10 +++-- guix/build/vm.scm | 102 ++++++++++++++++++++++++++++--------------------- 2 files changed, 64 insertions(+), 48 deletions(-) diff --git a/guix/build/install.scm b/guix/build/install.scm index f61c16f13a..663a87b4b5 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -37,7 +37,7 @@ (define* (install-grub grub.cfg device mount-point) "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. Return #t on success." +MOUNT-POINT." (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) (pivot (string-append target ".new"))) (mkdir-p (dirname target)) @@ -47,9 +47,11 @@ MOUNT-POINT. Return #t on success." (copy-file grub.cfg pivot) (rename-file pivot target) - (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" (string-append mount-point "/boot") - device)))) + (unless (zero? (system* "grub-install" "--no-floppy" + "--boot-directory" + (string-append mount-point "/boot") + device)) + (error "failed to install GRUB")))) (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 3c51ff8f34..2a8843c633 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -25,6 +25,9 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (load-in-linux-vm + format-partition + initialize-root-partition + initialize-partition-table initialize-hard-disk)) ;;; Commentary: @@ -113,16 +116,20 @@ The data at PORT is the format produced by #:references-graphs." (loop (read-line port) result))))) -(define* (initialize-partition-table device +(define* (initialize-partition-table device partition-size #:key (label-type "msdos") - partition-size) + (offset (expt 2 20))) "Create on DEVICE a partition table of type LABEL-TYPE, with a single -partition of PARTITION-SIZE MiB. Return #t on success." - (display "creating partition table...\n") - (zero? (system* "parted" device "mklabel" label-type - "mkpart" "primary" "ext2" "1MiB" - (format #f "~aB" partition-size)))) +partition of PARTITION-SIZE bytes starting at OFFSET bytes. Return #t on +success." + (format #t "creating partition table with a ~a B partition...\n" + partition-size) + (unless (zero? (system* "parted" device "mklabel" label-type + "mkpart" "primary" "ext2" + (format #f "~aB" offset) + (format #f "~aB" partition-size))) + (error "failed to create partition table"))) (define* (populate-store reference-graphs target) "Populate the store under directory TARGET with the items specified in @@ -146,43 +153,19 @@ REFERENCE-GRAPHS, a list of reference-graph files." (define MS_BIND 4096) ; again! -(define* (initialize-hard-disk device - #:key - grub.cfg - disk-image-size - (file-system-type "ext4") - (closures '()) - copy-closures? - (register-closures? #t) - (directives '())) - "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a -FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is -true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is -true, copy all of CLOSURES to the partition. Lastly, apply DIRECTIVES to -further populate the partition." - (define target-directory - "/fs") +(define (format-partition partition type) + "Create a file system TYPE on PARTITION." + (format #t "creating ~a partition...\n" type) + (unless (zero? (system* (string-append "mkfs." type) "-F" partition)) + (error "failed to create partition"))) +(define* (initialize-root-partition target-directory + #:key copy-closures? register-closures? + closures) + "Initialize the root partition mounted at TARGET-DIRECTORY." (define target-store (string-append target-directory (%store-directory))) - (define partition - (string-append device "1")) - - (unless (initialize-partition-table device - #:partition-size - (- disk-image-size (* 5 (expt 2 20)))) - (error "failed to create partition table")) - - (format #t "creating ~a partition...\n" file-system-type) - (unless (zero? (system* (string-append "mkfs." file-system-type) - "-F" partition)) - (error "failed to create partition")) - - (display "mounting partition...\n") - (mkdir target-directory) - (mount partition target-directory file-system-type) - (when copy-closures? ;; Populate the store. (populate-store (map (cut string-append "/xchg/" <>) closures) @@ -207,12 +190,43 @@ further populate the partition." (unless copy-closures? (system* "umount" target-store))) - ;; Evaluate the POPULATE directives. + ;; Add the non-store directories and files. (display "populating...\n") - (populate-root-file-system target-directory) + (populate-root-file-system target-directory)) + +(define* (initialize-hard-disk device + #:key + grub.cfg + disk-image-size + (file-system-type "ext4") + (closures '()) + copy-closures? + (register-closures? #t)) + "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a +FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is +true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is +true, copy all of CLOSURES to the partition." + (define target-directory + "/fs") + + (define partition + (string-append device "1")) + + (initialize-partition-table device + (- disk-image-size (* 5 (expt 2 20)))) + + (format-partition partition file-system-type) + + (display "mounting partition...\n") + (mkdir target-directory) + (mount partition target-directory file-system-type) + + (initialize-root-partition target-directory + #:copy-closures? copy-closures? + #:register-closures? register-closures? + #:closures closures) - (unless (install-grub grub.cfg device target-directory) - (error "failed to install GRUB")) + (install-grub grub.cfg device target-directory) ;; 'guix-register' resets timestamps and everything, so no need to do it ;; once more in that case. -- cgit v1.2.3 From a3977466db0aff6d1d82f3100745982d479bbff3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 10:38:41 +0200 Subject: build: Fix builds without --with-libgcrypt-prefix nor --with-libgcrypt-libdir. Reported by Manolis Ragkousis . Fixes a regression introduced in 14af289. Before this commit, ./configure would leave LIBGCRYPT_PREFIX and LIBGCRYPT_LIBDIR undefined, leading to LIBGCRYPT_LIBS="-L -lgcrypt" and thus to a link failure. * configure.ac: Make sure $LIBGCRYPT_PREFIX and $LIBGCRYPT_LIBDIR are never empty. --- configure.ac | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 7b2a0e4dd5..d65211779c 100644 --- a/configure.ac +++ b/configure.ac @@ -124,7 +124,9 @@ AC_ARG_WITH([libgcrypt-prefix], LIBGCRYPT_LIBDIR="$withval/lib" ;; esac], - [LIBGCRYPT="libgcrypt"]) + [LIBGCRYPT="libgcrypt" + LIBGCRYPT_PREFIX="no" + LIBGCRYPT_LIBDIR="no"]) AC_ARG_WITH([libgcrypt-libdir], [AS_HELP_STRING([--with-libgcrypt-libdir=DIR], @@ -141,6 +143,9 @@ AC_ARG_WITH([libgcrypt-libdir], esac], [if test "x$LIBGCRYPT" = x; then LIBGCRYPT="libgcrypt" + fi + if test "x$LIBGCRYPT_LIBDIR" = x; then + LIBGCRYPT_LIBDIR="no" fi]) dnl Library name suitable for `dynamic-link'. -- cgit v1.2.3 From 6d763bdddbea7a95f9f0bd5d5a1ada5e80c37fde Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 22 May 2014 21:58:08 +0200 Subject: guix: download: Update imagemagick mirrors. * guix/download.scm (%mirrors)[imagemagick]: Update and add the legacy subdirectory of the main site as a last resort. --- guix/download.scm | 29 +++++++++++++++++++++++------ 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/guix/download.scm b/guix/download.scm index 8ec17ae556..47b72f432a 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès -;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013, 2014 Andreas Enge ;;; ;;; This file is part of GNU Guix. ;;; @@ -157,13 +157,30 @@ "ftp://ftp.nara.wide.ad.jp/pub/CPAN/" "http://mirrors.163.com/cpan/" "ftp://cpan.mirror.ac.za/") - (imagemagick ; from http://www.imagemagick.org/script/download.php + (imagemagick + ;; from http://www.imagemagick.org/script/download.php + ;; (without mirrors that are unavailable or not up to date) + ;; mirrors keeping old versions at the top level + "ftp://ftp.sunet.se/pub/multimedia/graphics/ImageMagick/" + "ftp://sunsite.icm.edu.pl/packages/ImageMagick/" + ;; mirrors moving old versions to "legacy" + "http://mirrors-au.go-parts.com/mirrors/ImageMagick/" + "ftp://mirror.aarnet.edu.au/pub/imagemagick/" "http://mirror.checkdomain.de/imagemagick/" - "ftp://gd.tuwien.ac.at/pub/graphics/ImageMagick/" - "http://www.imagemagick.org/download" - "ftp://mirror.searchdaimon.com/ImageMagick" + "ftp://ftp.kddlabs.co.jp/graphics/ImageMagick/" + "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/" + "ftp://ftp.nluug.nl/pub/ImageMagick/" + "http://ftp.surfnet.nl/pub/ImageMagick/" + "http://mirror.searchdaimon.com/ImageMagick" + "ftp://ftp.tpnet.pl/pub/graphics/ImageMagick/" + "http://mirrors-ru.go-parts.com/mirrors/ImageMagick/" "http://mirror.is.co.za/pub/imagemagick/" - "ftp://mirror.aarnet.edu.au/pub/imagemagick/") + "http://mirrors-uk.go-parts.com/mirrors/ImageMagick/" + "http://mirrors-usa.go-parts.com/mirrors/ImageMagick/" + "ftp://ftp.fifi.org/pub/ImageMagick/" + "http://www.imagemagick.org/download/" + ;; one legacy location as a last resort + "http://www.imagemagick.org/download/legacy/") (debian "http://ftp.de.debian.org/debian/" "http://ftp.fr.debian.org/debian/" -- cgit v1.2.3 From 39aa11e090d3eb959d283737eb4adc2461aba369 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 22 May 2014 22:13:42 +0200 Subject: gnu: perl-io-tty: Upgrade to 1.11. * gnu/packages/perl.scm (perl-io-tty): Upgrade to 1.11. --- gnu/packages/perl.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/perl.scm b/gnu/packages/perl.scm index 6279120107..48b543436e 100644 --- a/gnu/packages/perl.scm +++ b/gnu/packages/perl.scm @@ -106,14 +106,14 @@ matching a regular expression.") (define-public perl-io-tty (package (name "perl-io-tty") - (version "1.10") + (version "1.11") (source (origin (method url-fetch) (uri (string-append "mirror://cpan/authors/id/T/TO/TODDR/IO-Tty-" version ".tar.gz")) (sha256 (base32 - "1cgqyv1zg8857inlnfczrrgpqr0r6mmqv29b7jlmxv47s4df59ii")))) + "0lgd9xcbi4gf4gw1ka6fj94my3w1f3k1zamb4pfln0qxz45zlxx4")))) (build-system perl-build-system) (home-page "http://search.cpan.org/~toddr/IO-Tty/") (synopsis "Perl interface to pseudo ttys") -- cgit v1.2.3 From ca143f13791e65a6469426523d1a1a75cc4295de Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 22 May 2014 22:28:12 +0200 Subject: gnu: imagemagick: Upgrade to 6.8.9-0. * gnu/packages/imagemagick.scm (imagemagick): Upgrade to 6.8.9-0. --- gnu/packages/imagemagick.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/imagemagick.scm b/gnu/packages/imagemagick.scm index d8c1afaaec..0c80c0a57f 100644 --- a/gnu/packages/imagemagick.scm +++ b/gnu/packages/imagemagick.scm @@ -37,14 +37,14 @@ (define-public imagemagick (package (name "imagemagick") - (version "6.8.8-10") + (version "6.8.9-0") (source (origin (method url-fetch) (uri (string-append "mirror://imagemagick/ImageMagick-" version ".tar.xz")) (sha256 (base32 - "0crdazi2f1qj1ppb01f0mhqjw5q3afswgw49fa1m100bxmqpf77k")))) + "1lapn2798fkc2wn81slpms5p21kq4dsyg45khsk7n8p69cvrmw2b")))) (build-system gnu-build-system) (arguments `(#:phases (alist-cons-before -- cgit v1.2.3 From 3035b50f28c1bcbc0a2bb09457a69ea9c06d69e0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 21:57:39 +0200 Subject: linux-initrd: Build /dev/loop* nodes. * guix/build/linux-initrd.scm (make-essential-device-nodes): Build /dev/loop[0-7]. --- guix/build/linux-initrd.scm | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 8db9f02caf..5be3c1ac2a 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -168,6 +168,14 @@ Return the value associated with OPTION, or #f on failure." (symlink "/proc/self/fd/1" (scope "dev/stdout")) (symlink "/proc/self/fd/2" (scope "dev/stderr")) + ;; Loopback devices. + (let loop ((i 0)) + (when (< i 8) + (mknod (scope (string-append "dev/loop" (number->string i))) + 'block-special #o660 + (device-number 7 i)) + (loop (+ 1 i)))) + ;; File systems in user space (FUSE). (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229))) -- cgit v1.2.3 From c4a74364b9ddb5c34bce788d453f93aa307731dd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 22:30:13 +0200 Subject: vm: Make the image format a parameter. * guix/build/vm.scm (load-in-linux-vm): Add #:disk-image-format parameter; add 'image-file' variable. Honor DISK-IMAGE-FORMAT. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add #:disk-image-format parameter, and honor it. (qemu-image): Likewise. --- gnu/system/vm.scm | 18 ++++++++++++------ guix/build/vm.scm | 10 +++++++--- 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 0d41791d87..39ce5bb6ef 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -119,6 +119,7 @@ input tuple. The output file name is when building for SYSTEM." (make-disk-image? #f) (references-graphs #f) (memory-size 256) + (disk-image-format "qcow2") (disk-image-size (* 100 (expt 2 20)))) "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a @@ -127,8 +128,9 @@ store; it should put its output files in the `/xchg' directory, which is copied to the derivation's output when the VM terminates. The virtual machine runs with MEMORY-SIZE MiB of memory. -When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of -DISK-IMAGE-SIZE bytes and return it. +When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type +DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and +return it. MODULES is the set of modules imported in the execution environment of EXP. @@ -174,6 +176,7 @@ made available under the /xchg CIFS share." #:linux linux #:initrd initrd #:memory-size #$memory-size #:make-disk-image? #$make-disk-image? + #:disk-image-format #$disk-image-format #:disk-image-size #$disk-image-size #:references-graphs graphs)))) @@ -190,15 +193,17 @@ made available under the /xchg CIFS share." (system (%current-system)) (qemu qemu-headless) (disk-image-size (* 100 (expt 2 20))) + (disk-image-format "qcow2") (file-system-type "ext4") grub-configuration (register-closures? #t) (inputs '()) copy-inputs?) - "Return a bootable, stand-alone QEMU image, with a root partition of type -FILE-SYSTEM-TYPE. The returned image is a full disk image, with a GRUB -installation that uses GRUB-CONFIGURATION as its configuration -file (GRUB-CONFIGURATION must be the name of a file in the VM.) + "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., +'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. The +returned image is a full disk image, with a GRUB installation that uses +GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the +name of a file in the VM.) INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, @@ -242,6 +247,7 @@ the image." #:system system #:make-disk-image? #t #:disk-image-size disk-image-size + #:disk-image-format disk-image-format #:references-graphs graph))) diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 2a8843c633..4de536abb4 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -50,6 +50,7 @@ (qemu (qemu-command)) (memory-size 512) linux initrd make-disk-image? (disk-image-size 100) + (disk-image-format "qcow2") (references-graphs '())) "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy the result to OUTPUT. @@ -60,9 +61,12 @@ it via /dev/hda. REFERENCES-GRAPHS can specify a list of reference-graph files as produced by the #:references-graphs parameter of 'derivation'." + (define image-file + (string-append "image." disk-image-format)) (when make-disk-image? - (unless (zero? (system* "qemu-img" "create" "-f" "qcow2" "image.qcow2" + (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format + image-file (number->string disk-image-size))) (error "qemu-img failed"))) @@ -92,12 +96,12 @@ the #:references-graphs parameter of 'derivation'." "-append" (string-append "console=ttyS0 --load=" builder) (if make-disk-image? - '("-hda" "image.qcow2") + `("-hda" ,image-file) '()))) (error "qemu failed" qemu)) (if make-disk-image? - (copy-file "image.qcow2" output) + (copy-file image-file output) (begin (mkdir output) (copy-recursively "xchg" output)))) -- cgit v1.2.3 From f19c6e5fe79c8bbd3c9ea25cd0380681bd99ce13 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 22:32:53 +0200 Subject: vm: Use a para-virtualized disk when creating an image. * guix/build/vm.scm (load-in-linux-vm): When MAKE-DISK-IMAGE?, use '-drive ...,if=virtio' for better performance. * gnu/system/vm.scm (qemu-image): Use /dev/vda instead of /dev/sda. --- gnu/system/vm.scm | 2 +- guix/build/vm.scm | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 39ce5bb6ef..7d0ffd971e 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -236,7 +236,7 @@ the image." (let ((graphs '#$(match inputs (((names . _) ...) names)))) - (initialize-hard-disk "/dev/sda" + (initialize-hard-disk "/dev/vda" #:grub.cfg #$grub-configuration #:closures graphs #:copy-closures? #$copy-inputs? diff --git a/guix/build/vm.scm b/guix/build/vm.scm index 4de536abb4..e559542f0a 100644 --- a/guix/build/vm.scm +++ b/guix/build/vm.scm @@ -96,7 +96,8 @@ the #:references-graphs parameter of 'derivation'." "-append" (string-append "console=ttyS0 --load=" builder) (if make-disk-image? - `("-hda" ,image-file) + `("-drive" ,(string-append "file=" image-file + ",if=virtio")) '()))) (error "qemu failed" qemu)) -- cgit v1.2.3 From c9384945984c393ef1a15efb5c07e272a27a2215 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 23:20:12 +0200 Subject: Add (gnu) module. * gnu.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. * build-aux/hydra/demo-os.scm: Use (gnu) and strip import list accordingly. * doc/guix.texi (Using the Configuration System): Adjust example accordingly. --- build-aux/hydra/demo-os.scm | 11 +++-------- doc/guix.texi | 3 +-- gnu-system.am | 1 + gnu.scm | 46 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 51 insertions(+), 10 deletions(-) create mode 100644 gnu.scm diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm index 5f0fd6a6f8..863371291e 100644 --- a/build-aux/hydra/demo-os.scm +++ b/build-aux/hydra/demo-os.scm @@ -22,9 +22,10 @@ ;;; machine images that we build. ;;; -(use-modules (gnu packages zile) +(use-modules (gnu) + + (gnu packages zile) (gnu packages xorg) - (gnu packages base) (gnu packages admin) (gnu packages guile) (gnu packages bash) @@ -33,12 +34,6 @@ (gnu packages tor) (gnu packages package-management) - (gnu system grub) ; 'grub-configuration' - (gnu system shadow) ; 'user-account' - (gnu system linux) ; 'base-pam-services' - (gnu system file-systems) ; 'file-systems' - - (gnu services base) (gnu services networking) (gnu services xorg)) diff --git a/doc/guix.texi b/doc/guix.texi index 57c9e4e52a..edb1dceeab 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3109,9 +3109,8 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this: @findex operating-system @lisp -(use-modules (gnu services base) ; for '%base-services' +(use-modules (gnu) ; for 'user-account', '%base-services', etc. (gnu services ssh) ; for 'lsh-service' - (gnu system shadow) ; for 'user-account' (gnu packages base) ; Coreutils, grep, etc. (gnu packages bash) ; Bash (gnu packages admin) ; dmd, Inetutils diff --git a/gnu-system.am b/gnu-system.am index 84a5e939f4..314db3e536 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -22,6 +22,7 @@ # binaries. GNU_SYSTEM_MODULES = \ + gnu.scm \ gnu/packages.scm \ gnu/packages/acct.scm \ gnu/packages/acl.scm \ diff --git a/gnu.scm b/gnu.scm new file mode 100644 index 0000000000..e573de6531 --- /dev/null +++ b/gnu.scm @@ -0,0 +1,46 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu)) + +;;; Commentary: +;;; +;;; This composite module re-exports core parts the (gnu …) public modules. +;;; +;;; Code: + +(eval-when (eval load compile) + (begin + (define %public-modules + '((gnu system) + (gnu system file-systems) + (gnu system grub) ; 'grub-configuration' + (gnu system linux) ; 'base-pam-services' + (gnu system shadow) ; 'user-account' + (gnu system linux-initrd) + (gnu services) + (gnu services base) + (gnu packages) + (gnu packages base))) + + (for-each (let ((i (module-public-interface (current-module)))) + (lambda (m) + (module-use! i (resolve-interface m)))) + %public-modules))) + +;;; gnu.scm ends here -- cgit v1.2.3 From 1e77fedb46af3c131b46da7ced55f7078d0d0e5f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 23:12:36 +0200 Subject: vm: Add 'system-disk-image'. * gnu/system/vm.scm (system-disk-image): New procedure. --- gnu/system/vm.scm | 40 ++++++++++++++++++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 2 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 7d0ffd971e..18635fd7e9 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -54,7 +54,8 @@ qemu-image system-qemu-image system-qemu-image/shared-store - system-qemu-image/shared-store-script)) + system-qemu-image/shared-store-script + system-disk-image)) ;;; Commentary: @@ -252,9 +253,44 @@ the image." ;;; -;;; Stand-alone VM image. +;;; VM and disk images. ;;; +(define* (system-disk-image os + #:key + (file-system-type "ext4") + (disk-image-size (* 900 (expt 2 20))) + (volatile? #t)) + "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the +system described by OS. Said image can be copied on a USB stick as is. When +VOLATILE? is true, the root file system is made volatile; this is useful +to USB sticks meant to be read-only." + (define file-systems-to-keep + (remove (lambda (fs) + (string=? (file-system-mount-point fs) "/")) + (operating-system-file-systems os))) + + (let ((os (operating-system (inherit os) + (initrd (cut qemu-initrd <> #:volatile-root? volatile?)) + + ;; Force our own root file system. + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/sda1") + (type file-system-type)) + file-systems-to-keep))))) + + (mlet* %store-monad ((os-drv (operating-system-derivation os)) + (grub.cfg (operating-system-grub.cfg os))) + (qemu-image #:grub-configuration grub.cfg + #:disk-image-size disk-image-size + #:disk-image-format "raw" + #:file-system-type file-system-type + #:copy-inputs? #t + #:register-closures? #t + #:inputs `(("system" ,os-drv) + ("grub.cfg" ,grub.cfg)))))) + (define* (system-qemu-image os #:key (file-system-type "ext4") -- cgit v1.2.3 From fb729425dcd80b8ef34c075867d2f204bc4d55cb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 May 2014 23:22:15 +0200 Subject: guix system: Add 'disk-image' action. * guix/scripts/system.scm (show-help): Add 'disk-image'. (guix-system)[parse-options]: Support 'disk-image' action. [option-arguments]: Likewise. Handle the 'disk-image' action. * doc/guix.texi (Invoking guix system): Document 'disk-image'. --- doc/guix.texi | 20 +++++++++++++++++--- guix/scripts/system.scm | 12 +++++++++--- 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index edb1dceeab..ddb0763495 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3236,9 +3236,23 @@ Build a virtual machine that contain the operating system declared in The VM shares its store with the host system. @item vm-image -Return a virtual machine image of the operating system declared in -@var{file} that stands alone. Use the @option{--image-size} option to -specify the size of the image. +@itemx disk-image +Return a virtual machine or disk image of the operating system declared +in @var{file} that stands alone. Use the @option{--image-size} option +to specify the size of the image. + +When using @code{vm-image}, the returned image is in qcow2 format, which +the QEMU emulator can efficiently use. + +When using @code{disk-image}, a raw disk image is produced; it can be +copied as is to a USB stick, for instance. Assuming @code{/dev/sdc} is +the device corresponding to a USB stick, one can copy the image on it +using the following command: + +@example +# dd if=$(guix system disk-image my-os.scm) of=/dev/sdc +@end example + @end table @var{options} can contain any of the common build options provided by diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index af48c57b54..345d8c3e5f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -129,6 +129,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (display (_ "\ - 'vm-image', build a freestanding virtual machine image\n")) (display (_ "\ + - 'disk-image', build a disk image, suitable for a USB stick\n")) + (display (_ "\ - 'init', initialize a root file system to run GNU.\n")) (show-build-options-help) @@ -191,7 +193,7 @@ Build the operating system declared in FILE according to ACTION.\n")) (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((build vm vm-image init) + ((build vm vm-image disk-image init) (alist-cons 'action action result)) (else (leave (_ "~a: unknown action~%") action)))))) @@ -214,7 +216,7 @@ Build the operating system declared in FILE according to ACTION.\n")) action)) (case action - ((build vm vm-image) + ((build vm vm-image disk-image) (unless (= count 1) (fail))) ((init) @@ -238,7 +240,11 @@ Build the operating system declared in FILE according to ACTION.\n")) (system-qemu-image os #:disk-image-size size))) ((vm) - (system-qemu-image/shared-store-script os)))) + (system-qemu-image/shared-store-script os)) + ((disk-image) + (let ((size (assoc-ref opts 'image-size))) + (system-disk-image os + #:disk-image-size size))))) (store (open-connection)) (dry? (assoc-ref opts 'dry-run?)) (drv (run-with-store store mdrv)) -- cgit v1.2.3 From a68d976b666a5097585cf221f4f8d793f90f3464 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 May 2014 22:19:37 +0200 Subject: download: Enlarge your receive buffer. * guix/build/download.scm (open-connection-for-uri): Remove call to 'setsockopt'. * guix/http-client.scm (open-socket-for-uri)[rmem-max, buffer-size]: New variables. Add call to 'setsockopt'. --- guix/build/download.scm | 2 -- guix/http-client.scm | 12 ++++++++++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/guix/build/download.scm b/guix/build/download.scm index 5d881b93ee..d98933a907 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -167,8 +167,6 @@ which is not available during bootstrap." ;; Buffer input and output on this port. (setvbuf s _IOFBF) - ;; Enlarge the receive buffer. - (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) (if (eq? 'https (uri-scheme uri)) (tls-wrap s) diff --git a/guix/http-client.scm b/guix/http-client.scm index 1f05df4b05..4770628e45 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -162,7 +162,19 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true." (define* (open-socket-for-uri uri #:key (buffered? #t)) "Return an open port for URI. When BUFFERED? is false, the returned port is unbuffered." + (define rmem-max + ;; The maximum size for a receive buffer on Linux, see socket(7). + "/proc/sys/net/core/rmem_max") + + (define buffer-size + (if (file-exists? rmem-max) + (call-with-input-file rmem-max read) + 126976)) ; the default for Linux, per 'rmem_default' + (let ((s ((@ (web client) open-socket-for-uri) uri))) + ;; Work around by restoring a decent + ;; buffer size. + (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) (unless buffered? (setvbuf s _IONBF)) s)) -- cgit v1.2.3 From 112440a7b832a3841bf8e8139975b43b78f8a6ab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 May 2014 22:35:08 +0200 Subject: vm: Disable QEMU networking in the disk image initrd. * gnu/system/linux-initrd.scm (qemu-initrd): Add #:qemu-networking? parameter and honor it. * gnu/system/vm.scm (system-disk-image): Pass #:qemu-networking #f. --- gnu/system/linux-initrd.scm | 6 +++++- gnu/system/vm.scm | 6 +++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 03199e0c39..b80ff10f1e 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -204,12 +204,16 @@ initrd code." (define* (qemu-initrd file-systems #:key guile-modules-in-chroot? + (qemu-networking? #t) volatile-root?) "Return a monadic derivation that builds an initrd for use in a QEMU guest where the store is shared with the host. 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'. +When QEMU-NETWORKING? is true, set up networking with the standard QEMU +parameters. + When VOLATILE-ROOT? is true, the root file system is writable but any changes to it are lost. @@ -267,7 +271,7 @@ exception and backtrace!)." (boot-system #:mounts '#$(map file-system->spec file-systems) #:linux-modules '#$linux-modules - #:qemu-guest-networking? #t + #:qemu-guest-networking? #$qemu-networking? #:guile-modules-in-chroot? '#$guile-modules-in-chroot? #:volatile-root? '#$volatile-root?)) #:name "qemu-initrd" diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 18635fd7e9..a15c4c358b 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -271,7 +271,11 @@ to USB sticks meant to be read-only." (operating-system-file-systems os))) (let ((os (operating-system (inherit os) - (initrd (cut qemu-initrd <> #:volatile-root? volatile?)) + ;; Since this is meant to be used on real hardware, don't set up + ;; QEMU networking. + (initrd (cut qemu-initrd <> + #:volatile-root? volatile? + #:qemu-networking? #f)) ;; Force our own root file system. (file-systems (cons (file-system -- cgit v1.2.3 From a9f48ff0766cfcd27426be540c7bb755f3093291 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 22 May 2014 13:28:34 -0500 Subject: gnu: Add lzop. * gnu/packages/compression.scm (lzop): New variable. --- gnu/packages/compression.scm | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/gnu/packages/compression.scm b/gnu/packages/compression.scm index a4c6f53202..c8328076cf 100644 --- a/gnu/packages/compression.scm +++ b/gnu/packages/compression.scm @@ -238,6 +238,29 @@ LZO is written in ANSI C. Both the source code and the compressed data format are designed to be portable across platforms.") (license license:gpl2+))) +(define-public lzop + (package + (name "lzop") + (version "1.03") + (source + (origin + (method url-fetch) + (uri (string-append "http://www.lzop.org/download/lzop-" + version ".tar.gz")) + (sha256 + (base32 + "1jdjvc4yjndf7ihmlcsyln2rbnbaxa86q4jskmkmm7ylfy65nhn1")))) + (build-system gnu-build-system) + (inputs `(("lzo" ,lzo))) + (home-page "http://www.lzop.org/") + (synopsis "Compress or expand files") + (description + "Lzop is a file compressor which is very similar to gzip. Lzop uses the +LZO data compression library for compression services, and its main advantages +over gzip are much higher compression and decompression speed (at the cost of +some compression ratio).") + (license license:gpl2+))) + (define-public lzip (package (name "lzip") -- cgit v1.2.3 From 484a2b3a5ac7337e5d3b8773f6ce8c356b72742b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 15:51:57 +0200 Subject: system: Separate the activation script from the boot script. * gnu/system.scm (operating-system-activation-script): New procedure, containing most of the former 'operating-system-boot-script'. (operating-system-boot-script): Call it, and 'primitive-load' its result. * guix/build/activation.scm (%booted-system): Remove. (activate-current-system): Remove #:boot? parameter and related code. --- gnu/system.scm | 27 ++++++++++++++++++++++----- guix/build/activation.scm | 18 ++++-------------- 2 files changed, 26 insertions(+), 19 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index 6cb7d303db..1d708179bd 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -348,9 +348,10 @@ alias ll='ls -l' ,#$(user-account-shell account) ; this one is a gexp #$(user-account-password account))) -(define (operating-system-boot-script os) - "Return the boot script for OS---i.e., the code started by the initrd once -we're running in the final root." +(define (operating-system-activation-script os) + "Return the activation script for OS---i.e., the code that \"activates\" the +stateful part of OS, including user accounts and groups, special directories, +etc." (define %modules '((guix build activation) (guix build utils) @@ -360,7 +361,6 @@ we're running in the final root." (etc (operating-system-etc-directory os)) (modules (imported-modules %modules)) (compiled (compiled-modules %modules)) - (dmd-conf (dmd-configuration-file services)) (accounts (operating-system-accounts os))) (define setuid-progs (operating-system-setuid-programs os)) @@ -399,7 +399,24 @@ we're running in the final root." (activate-setuid-programs (list #$@setuid-progs)) ;; Set up /run/current-system. - (activate-current-system #:boot? #t) + (activate-current-system))))) + +(define (operating-system-boot-script os) + "Return the boot script for OS---i.e., the code started by the initrd once +we're running in the final root." + (mlet* %store-monad ((services (operating-system-services os)) + (activate (operating-system-activation-script os)) + (dmd-conf (dmd-configuration-file services))) + (gexp->file "boot" + #~(begin + ;; Activate the system. + ;; TODO: Use 'load-compiled'. + (primitive-load #$activate) + + ;; Keep track of the booted system. + (false-if-exception (delete-file "/run/booted-system")) + (symlink (readlink "/run/current-system") + "/run/booted-system") ;; Close any remaining open file descriptors to be on the ;; safe side. This must be the very last thing we do, diff --git a/guix/build/activation.scm b/guix/build/activation.scm index 49f98c021d..62e69a9152 100644 --- a/guix/build/activation.scm +++ b/guix/build/activation.scm @@ -197,29 +197,19 @@ numeric gid or #f." (for-each make-setuid-program programs)) -(define %booted-system - ;; The system we booted in (a symlink.) - "/run/booted-system") - (define %current-system ;; The system that is current (a symlink.) This is not necessarily the same - ;; as %BOOTED-SYSTEM, for instance because we can re-build a new system - ;; configuration and activate it, without rebooting. + ;; as the system we booted (aka. /run/booted-system) because we can re-build + ;; a new system configuration and activate it, without rebooting. "/run/current-system") (define (boot-time-system) "Return the '--system' argument passed on the kernel command line." (find-long-option "--system" (linux-command-line))) -(define* (activate-current-system #:optional (system (boot-time-system)) - #:key boot?) - "Atomically make SYSTEM the current system. When BOOT? is true, also make -it the booted system." +(define* (activate-current-system #:optional (system (boot-time-system))) + "Atomically make SYSTEM the current system." (format #t "making '~a' the current system...~%" system) - (when boot? - (when (file-exists? %booted-system) - (delete-file %booted-system)) - (symlink system %booted-system)) ;; Atomically make SYSTEM current. (let ((new (string-append %current-system ".new"))) -- cgit v1.2.3 From 517830cc0154dbe4a77741e7ee61703c194086a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 17:53:30 +0200 Subject: system: Always create /var/empty. * guix/build/install.scm (directives): Add /var/empty. --- guix/build/install.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/guix/build/install.scm b/guix/build/install.scm index 663a87b4b5..24de954067 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -78,6 +78,7 @@ STORE." (directory "/var/log") ; for dmd (directory "/var/run/nscd") (directory "/var/guix/gcroots") + (directory "/var/empty") ; for no-login accounts (directory "/run") ("/var/guix/gcroots/booted-system" -> "/run/booted-system") ("/var/guix/gcroots/current-system" -> "/run/current-system") -- cgit v1.2.3 From 55ccc388b73312c9636857bb083f63a968b4255b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 18:03:27 +0200 Subject: services: Support per-service activation scripts. * gnu/services.scm ()[activate]: New field. * gnu/system.scm (operating-system-activation-script)[service-activations]: New procedure. Use it, and primitive-load each activation. --- gnu/services.scm | 5 ++++- gnu/system.scm | 11 +++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/gnu/services.scm b/gnu/services.scm index 8b89b11b8f..6bb21722b6 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -26,6 +26,7 @@ service-respawn? service-start service-stop + service-activate service-user-accounts service-user-groups service-pam-services)) @@ -54,6 +55,8 @@ (user-groups service-user-groups ; list of (default '())) (pam-services service-pam-services ; list of - (default '()))) + (default '())) + (activate service-activate ; gexp + (default #f))) ;;; services.scm ends here. diff --git a/gnu/system.scm b/gnu/system.scm index 1d708179bd..06bec40cef 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -357,7 +357,14 @@ etc." (guix build utils) (guix build linux-initrd))) + (define (service-activations services) + ;; Return the activation scripts for SERVICES. + (let ((gexps (filter-map service-activate services))) + (sequence %store-monad (map (cut gexp->file "activate-service.scm" <>) + gexps)))) + (mlet* %store-monad ((services (operating-system-services os)) + (actions (service-activations services)) (etc (operating-system-etc-directory os)) (modules (imported-modules %modules)) (compiled (compiled-modules %modules)) @@ -398,6 +405,10 @@ etc." ;; Activate setuid programs. (activate-setuid-programs (list #$@setuid-progs)) + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions) + ;; Set up /run/current-system. (activate-current-system))))) -- cgit v1.2.3 From 4b2615e1cae8e21df8f180abf261d1dc22a2459e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 May 2014 18:09:11 +0200 Subject: services: nscd: Provide an 'activate' script to make /var/run/nscd. * gnu/services/base.scm (nscd-service): Add 'activate' field. * guix/build/install.scm (directives): Remove /var/run/nscd; add /var/run. * doc/guix.texi (Defining Services): Add 'activate' field in example. Document it. --- doc/guix.texi | 19 +++++++++++++------ gnu/services/base.scm | 5 +++++ guix/build/install.scm | 2 +- 3 files changed, 19 insertions(+), 7 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index ddb0763495..bd853e6eac 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3299,6 +3299,9 @@ like: (return (service (documentation "Run libc's name service cache daemon.") (provision '(nscd)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd"))) (start #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") "-f" "/dev/null" "--foreground")) @@ -3307,12 +3310,16 @@ like: @end lisp @noindent -The @code{start} and @code{stop} fields are G-expressions -(@pxref{G-Expressions}). They refer to dmd's facilities to start and -stop processes (@pxref{Service De- and Constructors,,, dmd, GNU dmd -Manual}). The @code{provision} field specifies the name under which -this service is known to dmd, and @code{documentation} specifies on-line -documentation. Thus, the commands @command{deco start ncsd}, +The @code{activate}, @code{start}, and @code{stop} fields are G-expressions +(@pxref{G-Expressions}). The @code{activate} field contains a script to +run at ``activation'' time; it makes sure that the @file{/var/run/nscd} +directory exists before @command{nscd} is started. + +The @code{start} and @code{stop} fields refer to dmd's facilities to +start and stop processes (@pxref{Service De- and Constructors,,, dmd, +GNU dmd Manual}). The @code{provision} field specifies the name under +which this service is known to dmd, and @code{documentation} specifies +on-line documentation. Thus, the commands @command{deco start ncsd}, @command{deco stop nscd}, and @command{deco doc nscd} will do what you would expect (@pxref{Invoking deco,,, dmd, GNU dmd Manual}). diff --git a/gnu/services/base.scm b/gnu/services/base.scm index aec6050588..dc0161408b 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -225,6 +225,11 @@ stopped before 'kill' is called." (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) (requirement '(user-processes)) + + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd"))) + (start #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") "-f" "/dev/null" diff --git a/guix/build/install.scm b/guix/build/install.scm index 24de954067..afa7d1dd8f 100644 --- a/guix/build/install.scm +++ b/guix/build/install.scm @@ -76,9 +76,9 @@ STORE." `((directory ,store 0 0) (directory "/etc") (directory "/var/log") ; for dmd - (directory "/var/run/nscd") (directory "/var/guix/gcroots") (directory "/var/empty") ; for no-login accounts + (directory "/var/run") (directory "/run") ("/var/guix/gcroots/booted-system" -> "/run/booted-system") ("/var/guix/gcroots/current-system" -> "/run/current-system") -- cgit v1.2.3 From 884af1b4ecb0c6ede9fb431105c5c931d1bd1619 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 25 May 2014 01:31:15 +0200 Subject: store: Remove misleading 'setsockopt' call. * guix/store.scm (open-connection): Remove misleading 'setsockopt' call, erroneously introduced in df1fab58. This would actually shrink the receive buffer from 124 KiB to 12 KiB, though it had little impact on performance. --- guix/store.scm | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/guix/store.scm b/guix/store.scm index 864303ddb3..0c99e623ec 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -290,16 +290,6 @@ operate, should the disk become full. Return a server object." (socket PF_UNIX SOCK_STREAM 0))) (a (make-socket-address PF_UNIX file))) - (catch 'system-error - (lambda () - ;; Enlarge the receive buffer. - (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))) - (lambda args - ;; On the Hurd, the pflocal server's implementation of `socket_setopt' - ;; always returns ENOPROTOOPT. Ignore it. - (unless (= (system-error-errno args) ENOPROTOOPT) - (apply throw args)))) - (catch 'system-error (cut connect s a) (lambda args -- cgit v1.2.3 From 25083588b9d07077f77a495381f545b6a0e5ca69 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 25 May 2014 17:00:01 +0200 Subject: doc: Augment "Package Naming". * doc/guix.texi (Package Naming): Mention underscores, and give SDL_net as an example. --- doc/guix.texi | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index bd853e6eac..c10479ff12 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2812,12 +2812,15 @@ the string in the @code{name} field of a package definition. This name is used by package management commands such as @command{guix package} and @command{guix build}. -Both are usually the same and correspond to the lowercase conversion of the -project name chosen upstream. For instance, the GNUnet project is packaged -as @code{gnunet}. We do not add @code{lib} prefixes for library packages, -unless these are already part of the official project name. But see -@pxref{Python Modules} and @ref{Perl Modules} for special rules concerning -modules for the Python and Perl languages. +Both are usually the same and correspond to the lowercase conversion of +the project name chosen upstream, with underscores replaced with +hyphens. For instance, GNUnet is available as @code{gnunet}, and +SDL_net as @code{sdl-net}. + +We do not add @code{lib} prefixes for library packages, unless these are +already part of the official project name. But see @pxref{Python +Modules} and @ref{Perl Modules} for special rules concerning modules for +the Python and Perl languages. @node Version Numbers -- cgit v1.2.3 From de0b620e88226cc9da6eaabf5a7c6111ba0fba3e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 May 2014 00:08:50 +0200 Subject: gnu: Add inotify-tools. * gnu/packages/linux.scm (inotify-tools): New variable. --- gnu/packages/linux.scm | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index e9e7ebb99c..130a0f2a9a 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -1125,3 +1125,23 @@ system.") for systems using the Linux kernel. This includes commands such as 'loadkeys', 'setfont', 'kbdinfo', and 'chvt'.") (license gpl2+))) + +(define-public inotify-tools + (package + (name "inotify-tools") + (version "3.13") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://sourceforge/inotify-tools/inotify-tools/" + version "/inotify-tools-" version ".tar.gz")) + (sha256 + (base32 + "0icl4bx041axd5dvhg89kilfkysjj86hjakc7bk8n49cxjn4cha6")))) + (build-system gnu-build-system) + (home-page "http://inotify-tools.sourceforge.net/") + (synopsis "Monitor file accesses") + (description + "The inotify-tools packages provides a C library and command-line tools +to use Linux' inotify mechanism, which allows file accesses to be monitored.") + (license gpl2+))) -- cgit v1.2.3 From 7f0635f684b6646f266e1c890085e823b16f543d Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 20 May 2014 08:20:27 -0500 Subject: gnu: Add librsync. * gnu/packages/rsync.scm (librsync): New variable. --- gnu/packages/rsync.scm | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/gnu/packages/rsync.scm b/gnu/packages/rsync.scm index c51d65c33e..a55febfdf4 100644 --- a/gnu/packages/rsync.scm +++ b/gnu/packages/rsync.scm @@ -20,6 +20,7 @@ #:use-module (gnu packages) #:use-module (gnu packages perl) #:use-module (gnu packages acl) + #:use-module (gnu packages which) #:use-module (guix licenses) #:use-module (guix packages) #:use-module (guix download) @@ -49,3 +50,29 @@ by sending only the differences between the source files and the existing files in the destination.") (license gpl3+) (home-page "http://rsync.samba.org/"))) + +(define-public librsync + (package + (name "librsync") + (version "0.9.7") + (source (origin + (method url-fetch) + (uri (string-append "mirror://sourceforge/projects/librsync/librsync/" + version "/librsync-" version ".tar.gz")) + (sha256 + (base32 + "1mj1pj99mgf1a59q9f2mxjli2fzxpnf55233pc1klxk2arhf8cv6")))) + (build-system gnu-build-system) + (native-inputs + `(("which" ,which) + ("perl" ,perl))) + (arguments '(#:configure-flags '("--enable-shared"))) + (home-page "http://librsync.sourceforge.net/") + (synopsis "Implementation of the rsync remote-delta algorithm") + (description + "Librsync is a free software library that implements the rsync +remote-delta algorithm. This algorithm allows efficient remote updates of a +file, without requiring the old and new versions to both be present at the +sending end. The library uses a \"streaming\" design similar to that of zlib +with the aim of allowing it to be embedded into many different applications.") + (license lgpl2.1+))) -- cgit v1.2.3 From ff78435fa022578da012f582df506c7a6d6a0716 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Mon, 26 May 2014 01:15:53 -0500 Subject: gnu: Add mcrypt, libmcrypt, and libmhash. * gnu/packages/mcrypt.scm: New file. * gnu/packages/patches/mhash-keygen-test-segfault.patch: New patch. * gnu-system.am (GNU_SYSTEM_MODULES): Add file. (dist_patch_DATA): Add patch. --- gnu-system.am | 2 + gnu/packages/mcrypt.scm | 114 +++++++++++++++++++++ .../patches/mhash-keygen-test-segfault.patch | 13 +++ 3 files changed, 129 insertions(+) create mode 100644 gnu/packages/mcrypt.scm create mode 100644 gnu/packages/patches/mhash-keygen-test-segfault.patch diff --git a/gnu-system.am b/gnu-system.am index 314db3e536..04c2d1d368 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -152,6 +152,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/make-bootstrap.scm \ gnu/packages/maths.scm \ gnu/packages/mc.scm \ + gnu/packages/mcrypt.scm \ gnu/packages/messaging.scm \ gnu/packages/mit-krb5.scm \ gnu/packages/moe.scm \ @@ -323,6 +324,7 @@ dist_patch_DATA = \ gnu/packages/patches/make-impure-dirs.patch \ gnu/packages/patches/mc-fix-ncurses-build.patch \ gnu/packages/patches/mcron-install.patch \ + gnu/packages/patches/mhash-keygen-test-segfault.patch \ gnu/packages/patches/mit-krb5-init-fix.patch \ gnu/packages/patches/mpc123-initialize-ao.patch \ gnu/packages/patches/openssl-CVE-2010-5298.patch \ diff --git a/gnu/packages/mcrypt.scm b/gnu/packages/mcrypt.scm new file mode 100644 index 0000000000..eac8c72c5e --- /dev/null +++ b/gnu/packages/mcrypt.scm @@ -0,0 +1,114 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier +;;; +;;; 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 . + +(define-module (gnu packages mcrypt) + #:use-module (guix packages) + #:use-module ((guix licenses) #:select (gpl2+)) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module (gnu packages) + #:use-module (gnu packages compression) + #:use-module (gnu packages perl) + #:use-module (gnu packages file)) + +(define-public mcrypt + (package + (name "mcrypt") + (version "2.6.8") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://sourceforge/mcrypt/mcrypt-" + version ".tar.gz")) + (sha256 + (base32 + "161031n1w9pb4yzz9i47szc12a4mwpcpvyxnvafsik2l9s2aliai")))) + (build-system gnu-build-system) + (inputs + `(("zlib" ,zlib) + ("libmcrypt" ,libmcrypt) + ("libmhash" ,libmhash))) + (home-page "http://mcrypt.sourceforge.net/") + (synopsis "Replacement for the popular Unix crypt command") + (description + "MCrypt is a replacement for the old crypt() package and crypt(1) +command, with extensions. It allows developers to use a wide range of +encryption functions, without making drastic changes to their code. It allows +users to encrypt files or data streams without having to be cryptographers. +The companion to MCrypt is Libmcrypt, which contains the actual encryption +functions themselves, and provides a standardized mechanism for accessing +them.") + (license gpl2+))) + +(define-public libmcrypt + (package + (name "libmcrypt") + (version "2.5.8") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://sourceforge/mcrypt/libmcrypt-" + version ".tar.gz")) + (sha256 + (base32 + "0gipgb939vy9m66d3k8il98rvvwczyaw2ixr8yn6icds9c3nrsz4")))) + (build-system gnu-build-system) + (native-inputs `(("file" ,file))) + (home-page "http://mcrypt.sourceforge.net/") + (synopsis "Encryption algorithm library") + (description + "Libmcrypt is a data encryption library. The library is thread safe and +provides encryption and decryption functions. This version of the library +supports many encryption algorithms and encryption modes. Some algorithms +which are supported: SERPENT, RIJNDAEL, 3DES, GOST, SAFER+, CAST-256, RC2, +XTEA, 3WAY, TWOFISH, BLOWFISH, ARCFOUR, WAKE and more.") + (license gpl2+))) + +(define-public libmhash + (package + (name "libmhash") + (version "0.9.9.9") + (source + (origin + (method url-fetch) + + (uri (string-append "mirror://sourceforge/mhash/mhash-" + version ".tar.bz2")) + (sha256 + (base32 + "1w7yiljan8gf1ibiypi6hm3r363imm3sxl1j8hapjdq3m591qljn")) + (patches (list (search-patch "mhash-keygen-test-segfault.patch"))))) + (build-system gnu-build-system) + (native-inputs + `(("file" ,file) + ("perl" ,perl))) ;for tests + (home-page "http://mhash.sourceforge.net/") + (synopsis "Thread-safe hash library") + (description + "mhash is a thread-safe hash library, implemented in C, and provides a +uniform interface to a large number of hash algorithms. These algorithms can +be used to compute checksums, message digests, and other signatures. The HMAC +support implements the basics for message authentication, following RFC 2104. + +Algorithms currently supplied are: + +CRC-32, CRC-32B, ALDER-32, MD-2, MD-4, MD-5, RIPEMD-128, RIPEMD-160, +RIPEMD-256, RIPEMD-320, SHA-1, SHA-224, SHA-256, SHA-384, SHA-512, HAVAL-128, +HAVAL-160, HAVAL-192, HAVAL-256, TIGER, TIGER-128, TIGER-160, GOST, WHIRLPOOL, +SNEFRU-128, SNEFRU-256") + (license gpl2+))) diff --git a/gnu/packages/patches/mhash-keygen-test-segfault.patch b/gnu/packages/patches/mhash-keygen-test-segfault.patch new file mode 100644 index 0000000000..3bd9f43418 --- /dev/null +++ b/gnu/packages/patches/mhash-keygen-test-segfault.patch @@ -0,0 +1,13 @@ +This patch from resolution of https://sourceforge.net/p/mhash/bugs/37/ + +--- a/src/keygen_test.c ++++ b/src/keygen_test.c +@@ -121,8 +121,6 @@ + + mhash_keygen_ext(KEYGEN_S2K_SALTED, data, key, keysize, password, passlen); + +- mutils_memset(tmp, 0, keysize * 2); +- + tmp = mutils_asciify(key, keysize); + + result = mutils_strcmp((mutils_word8 *) KEY2, tmp); -- cgit v1.2.3 From 5698b8b82ce81e380908eff57c72464937116285 Mon Sep 17 00:00:00 2001 From: John Darrington Date: Sun, 25 May 2014 07:29:30 +0200 Subject: gnu: Add gsegrafix and dependent libraries. * gnu/packages/math.scm (gsegrafix): New variable. * gnu/packages/gtk.scm (pangox-compat): New variable. * gnu/packages/gnome.scm (libidl, orbit2, libbonobo, gconf, gnome-mime-data, gnome-vfs, libgnome, libart-lgpl, libgnomecanvas, libgnomeui, libglade, libgnomeprint, libgnomeprintui, libbonoboui): New variables. --- gnu/packages/gnome.scm | 480 +++++++++++++++++++++++++++++++++++++++++++++++++ gnu/packages/gtk.scm | 27 +++ gnu/packages/maths.scm | 35 ++++ 3 files changed, 542 insertions(+) diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index e889c9bff0..232afc6e44 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -24,14 +24,18 @@ #:use-module (guix download) #:use-module (guix build-system gnu) #:use-module (gnu packages) + #:use-module (gnu packages bison) + #:use-module (gnu packages flex) #:use-module (gnu packages glib) #:use-module (gnu packages gnupg) #:use-module (gnu packages gstreamer) #:use-module (gnu packages gtk) #:use-module (gnu packages pdf) + #:use-module (gnu packages popt) #:use-module (gnu packages ghostscript) #:use-module (gnu packages iso-codes) #:use-module (gnu packages libcanberra) + #:use-module (gnu packages libjpeg) #:use-module (gnu packages libpng) #:use-module (gnu packages perl) #:use-module (gnu packages pkg-config) @@ -610,3 +614,479 @@ dealing with different structured file formats.") "librsvg is a C library to render SVG files using the Cairo 2D graphics library.") (license license:lgpl2.0+))) + +(define-public libidl + (package + (name "libidl") + (version "0.8.14") + (source (origin + (method url-fetch) + (uri (let ((upstream-name "libIDL")) + (string-append + "mirror://gnome/sources/" upstream-name "/" (string-take version 3) "/" upstream-name "-" + version + ".tar.bz2"))) + (sha256 + (base32 + "08129my8s9fbrk0vqvnmx6ph4nid744g5vbwphzkaik51664vln5")))) + (build-system gnu-build-system) + (inputs `(("glib" ,glib))) + (native-inputs + `(("pkg-config" ,pkg-config) + ("flex", flex) + ("bison" ,bison))) + (home-page "http://freecode.com/projects/libidl") + (synopsis "Create trees of CORBA Interface Definition Language files") + (description "libidl is a library for creating trees of CORBA Interface +Definition Language (idl) files, which is a specification for defining +portable interfaces. libidl was initially written for orbit (the orb from the +GNOME project, and the primary means of libidl distribution). However, the +functionality was designed to be as reusable and portable as possible.") + (license license:lgpl2.0+))) + + +(define-public orbit2 + (package + (name "orbit2") + (version "2.14.19") + (source (origin + (method url-fetch) + (uri (let ((upstream-name "ORBit2")) + (string-append + "mirror://gnome/sources/" upstream-name "/" (string-take version 4) "/" upstream-name "-" + version + ".tar.bz2"))) + (sha256 + (base32 "0l3mhpyym9m5iz09fz0rgiqxl2ym6kpkwpsp1xrr4aa80nlh1jam")))) + (build-system gnu-build-system) + (arguments + ;; The programmer kindly gives us a hook to turn off deprecation warnings ... + `(#:configure-flags '("DISABLE_DEPRECATED_CFLAGS=-DGLIB_DISABLE_DEPRECATION_WARNINGS") + ;; ... which they then completly ignore !! + #:phases + (alist-cons-before + 'configure 'ignore-deprecations + (lambda _ + (substitute* "linc2/src/Makefile.in" + (("-DG_DISABLE_DEPRECATED") "-DGLIB_DISABLE_DEPRECATION_WARNINGS"))) + %standard-phases))) + (inputs `(("glib" ,glib) + ("libidl" ,libidl))) + (native-inputs + `(("pkg-config" ,pkg-config))) + (home-page "https://projects.gnome.org/orbit2/") + (synopsis "CORBA 2.4-compliant Object Request Broker") + (description "orbit2 is a CORBA 2.4-compliant Object Request Broker (orb) +featuring mature C, C++ and Python bindings.") + ;; Licence notice is unclear. The Web page simply say "GPL" without giving a version. + ;; SOME of the code files have licence notices for GPLv2+ + ;; The tarball contains files of the text of GPLv2 and LGPLv2 + (license license:gpl2+))) + + +(define-public libbonobo + (package + (name "libbonobo") + (version "2.32.1") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 4) "/" name "-" + version + ".tar.bz2")) + (sha256 + (base32 "0swp4kk6x7hy1rvd1f9jba31lvfc6qvafkvbpg9h0r34fzrd8q4i")))) + (build-system gnu-build-system) + (arguments + ;; The programmer kindly gives us a hook to turn off deprecation warnings ... + `(#:configure-flags '("DISABLE_DEPRECATED_CFLAGS=-DGLIB_DISABLE_DEPRECATION_WARNINGS") + ;; ... which they then completly ignore !! + #:phases + (alist-cons-before + 'configure 'ignore-deprecations + (lambda _ + (substitute* "activation-server/Makefile.in" + (("-DG_DISABLE_DEPRECATED") "-DGLIB_DISABLE_DEPRECATION_WARNINGS"))) + %standard-phases))) + (inputs `(("popt" ,popt) + ("libxml2" ,libxml2))) + ;; The following are Required by the .pc file + (propagated-inputs + `(("glib" ,glib) + ("orbit2" ,orbit2))) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config) + ("flex" ,flex) + ("bison" ,bison))) + (home-page "https://developer.gnome.org/libbonobo/") + (synopsis "Framework for creating reusable components for use in GNOME applications") + (description "Bonobo is a framework for creating reusable components for +use in GNOME applications, built on top of CORBA.") + ;; Licence not explicitly stated. Source files contain no licence notices. + ;; Tarball contains text of both GPLv2 and LGPLv2 + ;; GPLv2 covers both conditions + (license license:gpl2+))) + + +(define-public gconf + (package + (name "gconf") + (version "3.2.6") + (source (origin + (method url-fetch) + (uri + (let ((upstream-name "GConf")) + (string-append + "mirror://gnome/sources/" upstream-name "/" (string-take version 3) "/" upstream-name "-" + version + ".tar.xz"))) + (sha256 + (base32 "0k3q9nh53yhc9qxf1zaicz4sk8p3kzq4ndjdsgpaa2db0ccbj4hr")))) + (build-system gnu-build-system) + (inputs `(("glib" ,glib) + ("dbus" ,dbus) + ("dbus-glib" ,dbus-glib) + ("libxml2" ,libxml2))) + (propagated-inputs `(("orbit2" ,orbit2))) ; referred to in the .pc file + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (home-page "https://projects.gnome.org/gconf/") + (synopsis "store application preferences") + (description "gconf is a system for storing application preferences. It +is intended for user preferences; not arbitrary data storage.") + (license license:lgpl2.0+))) + + +(define-public gnome-mime-data + (package + (name "gnome-mime-data") + (version "2.18.0") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 4) "/" name "-" + version + ".tar.bz2")) + (sha256 + (base32 + "1mvg8glb2a40yilmyabmb7fkbzlqd3i3d31kbkabqnq86xdnn69p")))) + (build-system gnu-build-system) + (native-inputs + `(("perl" ,perl) + ("intltool" ,intltool))) + (home-page "http://www.gnome.org") + (synopsis "base MIME and Application database for GNOME") + (description "GNOME Mime Data is a module which contains the base MIME +and Application database for GNOME. The data stored by this module is +designed to be accessed through the MIME functions in GnomeVFS.") + (license license:gpl2+))) + + +(define-public gnome-vfs + (package + (name "gnome-vfs") + (version "2.24.4") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 4) "/" name "-" + version + ".tar.bz2")) + (sha256 + (base32 "1ajg8jb8k3snxc7rrgczlh8daxkjidmcv3zr9w809sq4p2sn9pk2")))) + (build-system gnu-build-system) + (arguments + ;; The programmer kindly gives us a hook to turn off deprecation warnings ... + `(#:configure-flags '("DISABLE_DEPRECATED_CFLAGS=-DGLIB_DISABLE_DEPRECATION_WARNINGS") + ;; ... which they then completly ignore !! + #:phases + (alist-cons-before + 'configure 'ignore-deprecations + (lambda _ + (begin + (substitute* "libgnomevfs/Makefile.in" + (("-DG_DISABLE_DEPRECATED") "-DGLIB_DISABLE_DEPRECATION_WARNINGS")) + (substitute* "daemon/Makefile.in" + (("-DG_DISABLE_DEPRECATED") "-DGLIB_DISABLE_DEPRECATION_WARNINGS")))) + %standard-phases))) + (inputs `(("glib" ,glib) + ("libxml2" ,libxml2) + ("dbus-glib" ,dbus-glib) + ("dbus" ,dbus) + ("gconf" ,gconf) + ("gnome-mime-data" ,gnome-mime-data) + ("zlib" ,zlib))) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (home-page "https://developer.gnome.org/gnome-vfs/") + (synopsis "access files and folders in GNOME applications") + (description "GnomeVFS is the core library used to access files and +folders in GNOME applications. It provides a file system abstraction which +allows applications to access local and remote files with a single consistent API.") + (license license:lgpl2.0+))) + + + +(define-public libgnome + (package + (name "libgnome") + (version "2.32.1") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 3) "/" name "-" + version + ".tar.bz2")) + (sha256 + (base32 + "197pnq8y0knqjhm2fg4j6hbqqm3qfzfnd0irhwxpk1b4hqb3kimj")))) + (build-system gnu-build-system) + (arguments + `(#:phases + (alist-cons-before + 'configure 'enable-deprecated + (lambda _ + (substitute* "libgnome/Makefile.in" + (("-DG_DISABLE_DEPRECATED") "-DGLIB_DISABLE_DEPRECATION_WARNINGS"))) + %standard-phases))) + (inputs `(("popt" ,popt) + ("libxml2" ,libxml2))) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + ;; The following are listed as Required in the .pc file + ;; (except for libcanberra -- which seems to be oversight on the part + ;; of the upstream developers -- anything that links against libgnome, + ;; must also link against libcanberra + (propagated-inputs + `(("libcanberra" ,libcanberra) + ("libbonobo" ,libbonobo) + ("gconf" ,gconf) + ("gnome-vfs" ,gnome-vfs) + ("glib" ,glib))) + (home-page "https://developer.gnome.org/libgnome/") + (synopsis "Useful routines for building applications") + (description "The libgnome library provides a number of useful routines +for building modern applications, including session management, activation of +files and URIs, and displaying help.") + (license license:lgpl2.0+))) + + +(define-public libart-lgpl + (package + (name "libart-lgpl") + (version "2.3.9") + (source (origin + (method url-fetch) + (uri (let ((upstream-name "libart_lgpl")) + (string-append + "mirror://gnome/sources/" upstream-name "/" + (string-take version 3) "/" upstream-name "-" version + ".tar.bz2"))) + (sha256 + (base32 + "072r4svs4hjf2f4gxzx02n3f970kdv9fpx54r2m8bd42fjyyawrw")))) + (build-system gnu-build-system) + (native-inputs + `(("pkg-config" ,pkg-config))) + (home-page "https://people.gnome.org/~mathieu/libart") + (synopsis "2D drawing library") + (description "Libart is a 2D drawing library intended as a +high-quality vector-based 2D library with antialiasing and alpha composition.") + (license license:lgpl2.0+))) + + + +(define-public libgnomecanvas + (package + (name "libgnomecanvas") + (version "2.30.3") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 4) "/" name "-" + version + ".tar.gz")) + (sha256 + (base32 + "1nhnq4lfkk8ljkdafscwaggx0h95mq0rxnd7zgqyq0xb6kkqbjm8")))) + (build-system gnu-build-system) + ;; Mentioned as Required in the .pc file + (propagated-inputs `(("libart-lgpl" ,libart-lgpl) + ("gtk+" ,gtk+-2))) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (home-page "https://developer.gnome.org/libgnomecanvas/") + (synopsis "Flexible widget for creating interactive structured graphics") + (description "The GnomeCanvas widget provides a flexible widget for +creating interactive structured graphics.") + (license license:lgpl2.0+))) + +(define-public libgnomeui + (package + (name "libgnomeui") + (version "2.24.5") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 4) "/" name "-" + version + ".tar.bz2")) + (sha256 + (base32 + "03rwbli76crkjl6gp422wrc9lqpl174k56cp9i96b7l8jlj2yddf")))) + (build-system gnu-build-system) + ;; Mentioned as Required in the .pc file + (propagated-inputs `(("libgnome" ,libgnome) + ("libgnome-keyring" ,libgnome-keyring))) + (inputs `(("libgnomecanvas" ,libgnomecanvas) + ("libbonoboui" ,libbonoboui) + ("libjpeg" ,libjpeg) + ("popt" ,popt) + ("libbonobo" ,libbonobo) + ("libxml2" ,libxml2) + ("libglade" ,libglade))) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (home-page "https://developer.gnome.org/libgnomeui/") + (synopsis "Additional widgets for applications") + (description "The libgnomeui library provides additional widgets for +applications. Many of the widgets from libgnomeui have already been ported to GTK+.") + (license license:lgpl2.0+))) + +(define-public libglade + (package + (name "libglade") + (version "2.6.4") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 3) "/" name "-" + version + ".tar.bz2")) + (sha256 + (base32 + "1v2x2s04jry4gpabws92i0wq2ghd47yr5n9nhgnkd7c38xv1wdk4")))) + (build-system gnu-build-system) + (inputs + `(("gtk+-2" ,gtk+-2) + ("libxml2" ,libxml2) + ("python" ,python))) ;; needed for the optional libglade-convert program + (native-inputs + `(("pkg-config" ,pkg-config))) + (home-page "https://developer.gnome.org/libglade") + (synopsis "load glade interfaces and access the glade built widgets") + (description "libglade is a library that provides interfaces for loading +graphical interfaces described in glade files and for accessing the +widgets built in the loading process.") + (license license:gpl2+))) ; This is correct. GPL not LGPL + +(define-public libgnomeprint + (package + (name "libgnomeprint") + (version "2.8.2") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 3) "/" name "-" + version + ".tar.bz2")) + (sha256 + (base32 + "129ka3nn8gx9dlfry17ib79azxk45wzfv5rgqzw6dwx2b5ns8phm")))) + (build-system gnu-build-system) + (inputs + `(("popt" ,popt) + ("libart-lgpl" ,libart-lgpl) + ("gtk+" ,gtk+-2) + ("libxml2" ,libxml2))) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (home-page "https://projects.gnome.org/gnome-print/home/faq.html") + (synopsis "printing framework for GNOME") + (description "Gnome-print is a high-quality printing framework for GNOME.") + (license license:lgpl2.0+))) + + +(define-public libgnomeprintui + (package + (name "libgnomeprintui") + (version "2.8.2") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 3) "/" name "-" + version + ".tar.bz2")) + (sha256 + (base32 + "1ivipk7r61rg90p9kp889j28xlyyj6466ypvwa4jvnrcllnaajsw")))) + (build-system gnu-build-system) + ;; Mentioned as Required in the .pc file + (propagated-inputs `(("libgnomeprint" ,libgnomeprint))) + (inputs `(("gtk+" ,gtk+-2) + ("glib" ,glib) + ("gnome-icon-theme" ,gnome-icon-theme) + ("libgnomecanvas" ,libgnomecanvas) + ("libxml2" ,libxml2))) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (home-page "https://projects.gnome.org/gnome-print/home/faq.html") + (synopsis "Printing framework for GNOME") + (description "Gnome-print is a high-quality printing framework for GNOME.") + (license license:lgpl2.0+))) + + +(define-public libbonoboui + (package + (name "libbonoboui") + (version "2.24.5") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 3) "/" name "-" + version + ".tar.bz2")) + (sha256 + (base32 + "1kbgqh7bw0fdx4f1a1aqwpff7gp5mwhbaz60c6c98bc4djng5dgs")))) + (build-system gnu-build-system) + (arguments + `(#:phases + (alist-cons-before + 'check 'start-xserver + (lambda* (#:key inputs #:allow-other-keys) + (let ((xorg-server (assoc-ref inputs "xorg-server")) + (disp ":1")) + + (setenv "HOME" (getcwd)) + (setenv "DISPLAY" disp) + ;; There must be a running X server and make check doesn't start one. + ;; Therefore we must do it. + (zero? (system (format #f "~a/bin/Xvfb ~a &" xorg-server disp))))) + %standard-phases))) + ;; Mentioned as Required by the .pc file + (propagated-inputs `(("libxml2" ,libxml2))) + (inputs + `(("popt" ,popt) + ("pangox-compat" ,pangox-compat) + ("libgnome" ,libgnome) + ("libgnomecanvas" ,libgnomecanvas) + ("libglade" ,libglade))) + (native-inputs + `(("intltool" ,intltool) + ("xorg-server" ,xorg-server) ; For running the tests + ("pkg-config" ,pkg-config))) + (home-page "https://developer.gnome.org/libbonoboui/") + (synopsis "Some user interface controls using Bonobo") + (description "The Bonobo UI library provides a number of user interface +controls using the Bonobo component framework.") + (license license:lgpl2.0+))) + diff --git a/gnu/packages/gtk.scm b/gnu/packages/gtk.scm index 7600103da3..54cfbfb5f1 100644 --- a/gnu/packages/gtk.scm +++ b/gnu/packages/gtk.scm @@ -169,6 +169,33 @@ used throughout the world.") (license license:lgpl2.0+) (home-page "https://developer.gnome.org/pango/"))) +(define-public pangox-compat + (package + (name "pangox-compat") + (version "0.0.2") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" (string-take version 3) "/" name "-" + version + ".tar.xz")) + (sha256 + (base32 + "0ip0ziys6mrqqmz4n71ays0kf5cs1xflj1gfpvs4fgy2nsrr482m")))) + (build-system gnu-build-system) + (inputs + `(("glib" ,glib) + ("pango" ,pango))) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (home-page "https://developer.gnome.org/pango") + (synopsis "functions now obsolete in pango") + (description "Pangox was a X backend to pango. It is now obsolete and no +longer provided by recent pango releases. pangox-compat provides the +functions which were removed.") + (license license:lgpl2.0+))) + (define-public gtksourceview (package diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 4fcb997f34..8ef4f44f5a 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -43,11 +43,13 @@ #:use-module (gnu packages ghostscript) #:use-module (gnu packages gtk) #:use-module (gnu packages less) + #:use-module (gnu packages gnome) #:use-module (gnu packages xorg) #:use-module (gnu packages gl) #:use-module (gnu packages mpi) #:use-module (gnu packages multiprecision) #:use-module (gnu packages pcre) + #:use-module (gnu packages popt) #:use-module (gnu packages perl) #:use-module (gnu packages pkg-config) #:use-module (gnu packages python) @@ -791,3 +793,36 @@ bio-chemistry.") "install")))) ,scotch-phases)))))) (synopsis "Programs and libraries for graph algorithms (with MPI)"))) + +(define-public gsegrafix + (package + (name "gsegrafix") + (version "1.0.6") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://gnu/" name "/" name "-" + version ".tar.gz")) + (sha256 + (base32 + "1b13hvx063zv970y750bx41wpx6hwd5ngjhbdrna8w8yy5kmxcda")))) + (build-system gnu-build-system) + (arguments + `(#:configure-flags '("LDFLAGS=-lm"))) + (inputs + `(("libgnomecanvas" ,libgnomecanvas) + ("libbonoboui" ,libbonoboui) + ("libgnomeui" ,libgnomeui) + ("libgnomeprintui" ,libgnomeprintui) + ("popt" ,popt))) + (native-inputs + `(("pkg-config" ,pkg-config))) + (home-page "http://www.gnu.org/software/gsegrafix/") + (synopsis "GNOME application to create scientific and engineering plots") + (description "GSEGrafix is an application which produces high-quality graphical +plots for science and engineering. Plots are specified via simple ASCII +parameter files and data files and are presented in an anti-aliased GNOME +canvas. The program supports rectangular two-dimensional plots, histograms, +polar-axis plots and three-dimensional plots. Plots can be printed or saved +to BMP, JPEG or PNG image formats.") + (license license:gpl3+))) -- cgit v1.2.3 From 3963a7292a1c098b7539962daf5dd82f2faefed1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 May 2014 11:51:49 +0200 Subject: gnu: Add Transmission. * gnu/packages/bittorrent.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. --- gnu-system.am | 1 + gnu/packages/bittorrent.scm | 91 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 92 insertions(+) create mode 100644 gnu/packages/bittorrent.scm diff --git a/gnu-system.am b/gnu-system.am index 04c2d1d368..ab8bf113f5 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -40,6 +40,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/bash.scm \ gnu/packages/bdb.scm \ gnu/packages/bdw-gc.scm \ + gnu/packages/bittorrent.scm \ gnu/packages/bison.scm \ gnu/packages/boost.scm \ gnu/packages/bootstrap.scm \ diff --git a/gnu/packages/bittorrent.scm b/gnu/packages/bittorrent.scm new file mode 100644 index 0000000000..e21b7fbee2 --- /dev/null +++ b/gnu/packages/bittorrent.scm @@ -0,0 +1,91 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu packages bittorrent) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module ((guix licenses) + #:renamer (symbol-prefix-proc 'l:)) + #:use-module (gnu packages openssl) + #:use-module (gnu packages libevent) + #:use-module (gnu packages curl) + #:use-module (gnu packages pkg-config) + #:use-module (gnu packages file) + #:use-module (gnu packages linux) + #:use-module ((gnu packages compression) + #:select (zlib)) + #:use-module (gnu packages glib) + #:use-module (gnu packages gtk)) + +(define-public transmission + (package + (name "transmission") + (version "2.83") + (source (origin + (method url-fetch) + (uri (string-append + "https://transmission.cachefly.net/transmission-" + version ".tar.xz")) + (sha256 + (base32 + "0cqlgl6jmjw1caybz6nzh3l8z0jak1dxba01isv72zvy2r8b1qdh")))) + (build-system gnu-build-system) + (outputs '("out" ; library and command-line interface + "gui")) ; graphical user interface + (arguments + '(#:phases (alist-cons-after + 'install 'move-gui + (lambda* (#:key outputs #:allow-other-keys) + ;; Move the GUI to its own output, so that "out" doesn't + ;; depend on GTK+. + (let ((out (assoc-ref outputs "out")) + (gui (assoc-ref outputs "gui"))) + (mkdir-p (string-append gui "/bin")) + (rename-file (string-append out "/bin/transmission-gtk") + (string-append gui + "/bin/transmission-gtk")))) + %standard-phases))) + (inputs + `(("inotify-tools" ,inotify-tools) + ("libevent" ,libevent) + ("curl" ,curl) + ("openssl" ,openssl) + ("file" ,file) + ("zlib" ,zlib) + ("gtk+" ,gtk+))) + (native-inputs + `(("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (home-page "http://www.transmissionbt.com/") + (synopsis "Fast and easy BitTorrent client") + (description + "Transmission is a BitTorrent client that comes with graphical, +textual, and Web user interfaces. Transmission also has a daemon for +unattended operationg. It supports local peer discovery, full encryption, +DHT, µTP, PEX and Magnet Links.") + + ;; COPYING reads: + ;; + ;; Transmission can be redistributed and/or modified under the terms of + ;; the GNU GPLv2 (http://www.gnu.org/licenses/license-list.html#GPLv2), + ;; the GNU GPLv3 (http://www.gnu.org/licenses/license-list.html#GNUGPLv3), + ;; or any future license endorsed by Mnemosyne LLC. + ;; + ;; A few files files carry an MIT/X11 license header. + (license l:gpl3+))) -- cgit v1.2.3 From f4561be2d13668bbb38dcb01d8bfe56c8c12bf0f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 May 2014 18:23:12 +0200 Subject: services: Add D-Bus and Avahi. * gnu/services/dbus.scm: New file. * gnu/services/avahi.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add them. --- gnu-system.am | 2 + gnu/services/avahi.scm | 108 ++++++++++++++++++++++++++++++++++++++++++++ gnu/services/dbus.scm | 120 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 230 insertions(+) create mode 100644 gnu/services/avahi.scm create mode 100644 gnu/services/dbus.scm diff --git a/gnu-system.am b/gnu-system.am index ab8bf113f5..242dc2d134 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -245,7 +245,9 @@ GNU_SYSTEM_MODULES = \ gnu/packages/zip.scm \ \ gnu/services.scm \ + gnu/services/avahi.scm \ gnu/services/base.scm \ + gnu/services/dbus.scm \ gnu/services/dmd.scm \ gnu/services/networking.scm \ gnu/services/xorg.scm \ diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm new file mode 100644 index 0000000000..4b52fd7840 --- /dev/null +++ b/gnu/services/avahi.scm @@ -0,0 +1,108 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu services avahi) + #:use-module (gnu services) + #:use-module (gnu system shadow) + #:use-module (gnu packages avahi) + #:use-module (guix monads) + #:use-module (guix gexp) + #:export (avahi-service)) + +;;; Commentary: +;;; +;;; This module provides service definitions for the Avahi +;;; "zero-configuration" tool set. +;;; +;;; Code: + +(define* (configuration-file #:key host-name publish? + ipv4? ipv6? wide-area? domains-to-browse) + "Return an avahi-daemon configuration file." + (define (bool value) + (if value "yes\n" "no\n")) + + (text-file "avahi-daemon.conf" + (string-append + "[server]\n" + (if host-name + (string-append "host-name=" host-name "\n") + "") + + "browse-domains=" (string-join domains-to-browse) + "\n" + "use-ipv4=" (bool ipv4?) + "use-ipv6=" (bool ipv6?) + "[wide-area]\n" + "enable-wide-area=" (bool wide-area?) + "[publish]\n" + "disable-publishing=" (bool (not publish?))))) + +(define* (avahi-service #:key (avahi avahi) + host-name + (publish? #t) + (ipv4? #t) (ipv6? #t) + wide-area? + (domains-to-browse '())) + "Return a service that runs @command{avahi-daemon}, a system-wide +mDNS/DNS-SD responder that allows for service discovery and +\"zero-configuration\" host name lookups. + +If @var{host-name} is different from @code{#f}, use that as the host name to +publish for this machine; otherwise, use the machine's actual host name. + +When @var{publish?} is true, publishing of host names and services is allowed; +in particular, avahi-daemon will publish the machine's host name and IP +address via mDNS on the local network. + +When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled. + +Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6 +sockets." + (mlet %store-monad ((config (configuration-file #:host-name host-name + #:publish? publish? + #:ipv4? ipv4? + #:ipv6? ipv6? + #:wide-area? wide-area? + #:domains-to-browse + domains-to-browse))) + (return + (service + (documentation "Run the Avahi mDNS/DNS-SD responder.") + (provision '(avahi-daemon)) + (requirement '(dbus-system networking)) + + (start #~(make-forkexec-constructor + (string-append #$avahi "/sbin/avahi-daemon") + "--syslog" "-f" #$config)) + (stop #~(make-kill-destructor)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/avahi-daemon"))) + + (user-groups (list (user-group + (name "avahi")))) + (user-accounts (list (user-account + (name "avahi") + (group "avahi") + (comment "Avahi daemon user") + (home-directory "/var/empty") + (shell + "/run/current-system/profile/sbin/nologin")))))))) + +;;; avahi.scm ends here diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm new file mode 100644 index 0000000000..3fbbfde09b --- /dev/null +++ b/gnu/services/dbus.scm @@ -0,0 +1,120 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu services dbus) + #:use-module (gnu services) + #:use-module (gnu system shadow) + #:use-module (gnu packages glib) + #:use-module (guix monads) + #:use-module (guix gexp) + #:export (dbus-service)) + +;;; Commentary: +;;; +;;; This module supports the configuration of the D-Bus message bus +;;; (http://dbus.freedesktop.org/). D-Bus is an inter-process communication +;;; facility. Its "system bus" is used to allow system services to +;;; communicate and be notified of system-wide events. +;;; +;;; Code: + +(define (dbus-configuration-directory dbus services) + "Return a configuration directory for @var{dbus} that includes the +@code{etc/dbus-1/system.d} directories of each package listed in +@var{services}." + (define build + #~(begin + (use-modules (sxml simple)) + + (define (services->sxml services) + ;; Return the SXML 'includedir' clauses for DIRS. + `(busconfig + ,@(map (lambda (dir) + `(includedir ,(string-append dir + "/etc/dbus-1/system.d"))) + services))) + + (mkdir #$output) + (copy-file (string-append #$dbus "/etc/dbus-1/system.conf") + (string-append #$output "/system.conf")) + + ;; The default 'system.conf' has an clause for + ;; 'system.d', so create it. + (mkdir (string-append #$output "/system.d")) + + ;; 'system-local.conf' is automatically included by the default + ;; 'system.conf', so this is where we stuff our own things. + (call-with-output-file (string-append #$output "/system-local.conf") + (lambda (port) + (sxml->xml (services->sxml (list #$@services)) + port))))) + + (gexp->derivation "dbus-configuration" build)) + +(define* (dbus-service services #:key (dbus dbus)) + "Return a service that runs the system bus, using @var{dbus}, with support +for @var{services}. + +@var{services} must be a list of packages that provide an +@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration +and policy files. For example, to allow avahi-daemon to use the system bus, +@var{services} must be equal to @code{(list avahi)}." + (mlet %store-monad ((conf (dbus-configuration-directory dbus services))) + (return + (service + (documentation "Run the D-Bus system daemon.") + (provision '(dbus-system)) + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (string-append #$dbus "/bin/dbus-daemon") + "--nofork" + (string-append "--config-file=" #$conf "/system.conf"))) + (stop #~(make-kill-destructor)) + (user-groups (list (user-group + (name "messagebus")))) + (user-accounts (list (user-account + (name "messagebus") + (group "messagebus") + (comment "D-Bus system bus user") + (home-directory "/var/run/dbus") + (shell + "/run/current-system/profile/sbin/nologin")))) + (activate #~(begin + (use-modules (guix build utils)) + + (mkdir-p "/var/run/dbus") + + (let ((user (getpwnam "messagebus"))) + (chown "/var/run/dbus" + (passwd:uid user) (passwd:gid user))) + + (unless (file-exists? "/etc/machine-id") + (format #t "creating /etc/machine-id...~%") + (let ((prog (string-append #$dbus "/bin/dbus-uuidgen"))) + ;; XXX: We can't use 'system' because the initrd's + ;; guile system(3) only works when 'sh' is in $PATH. + (let ((pid (primitive-fork))) + (if (zero? pid) + (call-with-output-file "/etc/machine-id" + (lambda (port) + (close-fdes 1) + (dup2 (port->fdes port) 1) + (execl prog))) + (waitpid pid))))))))))) + +;;; dbus.scm ends here -- cgit v1.2.3 From c1448c69747c7e8bd2a2e911b96c7f2837fee691 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 27 May 2014 10:01:52 -0500 Subject: gnu: Add python-lockfile. * gnu/packages/python.scm (python-lockfile): New variable. --- gnu/packages/python.scm | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index d3d4f390ff..53d1f3edb4 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -21,7 +21,7 @@ (define-module (gnu packages python) #:use-module ((guix licenses) - #:select (bsd-3 bsd-style psfl x11 x11-style + #:select (bsd-3 bsd-style expat psfl x11 x11-style gpl2 gpl2+ lgpl2.1+)) #:use-module ((guix licenses) #:select (zlib) #:renamer (symbol-prefix-proc 'license:)) @@ -293,6 +293,30 @@ etc. ") (define-public python2-babel (package-with-python2 python-babel)) +(define-public python-lockfile + (package + (name "python-lockfile") + (version "0.9.1") + (source + (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/l/lockfile/" + "lockfile-" version ".tar.gz")) + (sha256 + (base32 + "0iwif7i84gwpvrnpv4brshdk8j6l77smvknm8k3bg77mj6f5ini3")))) + (build-system python-build-system) + (arguments '(#:test-target "check")) + (home-page "http://code.google.com/p/pylockfile/") + (synopsis "Platform-independent file locking module") + (description + "The lockfile package exports a LockFile class which provides a simple +API for locking files.") + (license expat))) + +(define-public python2-lockfile + (package-with-python2 python-lockfile)) + (define-public python-setuptools (package -- cgit v1.2.3 From 5a1a4bf6b2cc2a7652d0c9199b22af6297b78f7e Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 27 May 2014 10:02:16 -0500 Subject: gnu: Add python-mock. * gnu/packages/python.scm (python-mock): New variable. --- gnu/packages/python.scm | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 53d1f3edb4..b15e5b66d2 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -317,6 +317,31 @@ API for locking files.") (define-public python2-lockfile (package-with-python2 python-lockfile)) +(define-public python-mock + (package + (name "python-mock") + (version "1.0.1") + (source + (origin + (method url-fetch) + (uri (string-append "https://pypi.python.org/packages/source/m/mock/" + "mock-" version ".tar.gz")) + (sha256 + (base32 + "0kzlsbki6q0awf89rc287f3aj8x431lrajf160a70z0ikhnxsfdq")))) + (build-system python-build-system) + (arguments '(#:test-target "check")) + (home-page "http://code.google.com/m/mock/") + (synopsis "A Python Mocking and Patching Library for Testing") + (description + "Mock is a library for testing in Python. It allows you to replace parts +of your system under test with mock objects and make assertions about how they +have been used.") + (license expat))) + +(define-public python2-mock + (package-with-python2 python-mock)) + (define-public python-setuptools (package -- cgit v1.2.3 From d1a5439bcbb1da781e08a69a630722af626263d2 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 27 May 2014 10:04:42 -0500 Subject: gnu: Add duplicity. * gnu/packages/backup.scm: New file. * gnu-system.am: Add it. --- gnu-system.am | 1 + gnu/packages/backup.scm | 71 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+) create mode 100644 gnu/packages/backup.scm diff --git a/gnu-system.am b/gnu-system.am index 242dc2d134..6cd98c6aea 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -36,6 +36,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/autogen.scm \ gnu/packages/autotools.scm \ gnu/packages/avahi.scm \ + gnu/packages/backup.scm \ gnu/packages/base.scm \ gnu/packages/bash.scm \ gnu/packages/bdb.scm \ diff --git a/gnu/packages/backup.scm b/gnu/packages/backup.scm new file mode 100644 index 0000000000..574bb11816 --- /dev/null +++ b/gnu/packages/backup.scm @@ -0,0 +1,71 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier +;;; +;;; 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 . + +(define-module (gnu packages backup) + #:use-module (guix packages) + #:use-module (guix licenses) + #:use-module (guix download) + #:use-module (guix build-system python) + #:use-module (gnu packages) + #:use-module (gnu packages python) + #:use-module (gnu packages gnupg) + #:use-module (gnu packages rsync) + #:use-module (srfi srfi-1)) + +(define-public duplicity + (package + (name "duplicity") + (version "0.6.24") + (source + (origin + (method url-fetch) + (uri (string-append "https://code.launchpad.net/duplicity/" + (string-join (take (string-split version #\.) 2) ".") + "-series/" version "/+download/duplicity-" + version ".tar.gz")) + (sha256 + (base32 + "0l14nrhbgkyjgvh339bbhnm6hrdwrjadphq1jmpi0mcgcdbdfh8x")))) + (build-system python-build-system) + (native-inputs + `(("python2-setuptools" ,python2-setuptools))) + (inputs + `(("python" ,python-2) + ("librsync" ,librsync) + ("mock" ,python2-mock) ;for testing + ("lockfile" ,python2-lockfile) + ("gnupg" ,gnupg-1))) ;gpg executable needed + (arguments + `(#:python ,python-2 ;setup assumes Python 2 + #:test-target "test" + #:phases (alist-cons-before + 'check 'patch-tests + (lambda _ + (substitute* "testing/functional/__init__.py" + (("/bin/sh") (which "sh")))) + %standard-phases))) + (home-page "http://duplicity.nongnu.org/index.html") + (synopsis "Encrypted backup using rsync algorithm") + (description + "Duplicity backs up directories by producing encrypted tar-format volumes +and uploading them to a remote or local file server. Because duplicity uses +librsync, the incremental archives are space efficient and only record the +parts of files that have changed since the last backup. Because duplicity +uses GnuPG to encrypt and/or sign these archives, they will be safe from +spying and/or modification by the server.") + (license gpl2+))) -- cgit v1.2.3 From 33dcd2a80410d9dbd9b4428ed6a7ef59cd1b0493 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 27 May 2014 10:38:57 -0500 Subject: gnu: librsync: Fix source uri * gnu/packages/rsync.scm (librsync) [source]: Fix sourceforge uri. --- gnu/packages/rsync.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnu/packages/rsync.scm b/gnu/packages/rsync.scm index a55febfdf4..9c1a7a3b34 100644 --- a/gnu/packages/rsync.scm +++ b/gnu/packages/rsync.scm @@ -57,7 +57,7 @@ files in the destination.") (version "0.9.7") (source (origin (method url-fetch) - (uri (string-append "mirror://sourceforge/projects/librsync/librsync/" + (uri (string-append "mirror://sourceforge/librsync/librsync/" version "/librsync-" version ".tar.gz")) (sha256 (base32 -- cgit v1.2.3 From 2a7050abf8ae27d6ee929426cadd3889be611ff8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 May 2014 14:51:57 +0200 Subject: gnu: Add Autoconf 2.64. * gnu/packages/autotools.scm (autoconf-2.64): New variable. --- gnu/packages/autotools.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/gnu/packages/autotools.scm b/gnu/packages/autotools.scm index bd38f2a901..db1db45fc1 100644 --- a/gnu/packages/autotools.scm +++ b/gnu/packages/autotools.scm @@ -74,6 +74,20 @@ know anything about Autoconf or M4.") (base32 "1fjm21k2na07f3vasf288a0zx66lbv0hd3l9bvv3q8p62s3pg569")))))) +(define-public autoconf-2.64 + ;; As of GDB 7.8, GDB is still developed using this version of Autoconf. + (package (inherit autoconf) + (version "2.64") + (source + (origin + (method url-fetch) + (uri (string-append "mirror://gnu/autoconf/autoconf-" + version ".tar.xz")) + (sha256 + (base32 + "0j3jdjpf5ly39dlp0bg70h72nzqr059k0x8iqxvaxf106chpgn9j")))))) + + (define* (autoconf-wrapper #:optional (autoconf autoconf)) "Return an wrapper around AUTOCONF that generates `configure' scripts that use our own Bash instead of /bin/sh in shebangs. For that reason, it should -- cgit v1.2.3 From 5895f2444317ba74eeab21d517c703c3687165c0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 May 2014 22:01:51 +0200 Subject: store: Work around 'get-bytevector-n' bug that affects 'import-paths'. Fixes . * guix/store.scm (process-stderr) <%stderr-read>: Use 'get-bytevector-n!' instead of 'get-bytevector-n'. --- guix/store.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/guix/store.scm b/guix/store.scm index 0c99e623ec..8c774a6db2 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -397,11 +397,13 @@ encoding conversion errors." #f) ((= k %stderr-read) ;; Read a byte stream from USER-PORT. + ;; Note: Avoid 'get-bytevector-n' to work around + ;; in Guile up to 2.0.11. (let* ((max-len (read-int p)) - (data (get-bytevector-n user-port max-len)) - (len (bytevector-length data))) + (data (make-bytevector max-len)) + (len (get-bytevector-n! user-port data 0 max-len))) (write-int len p) - (put-bytevector p data) + (put-bytevector p data 0 len) (write-padding len p) #f)) ((= k %stderr-next) -- cgit v1.2.3 From 35066aa596931ef84922298c2760ceba69940cd1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 May 2014 22:36:54 +0200 Subject: syscalls: Be more permissive in 'umount' test. * tests/syscalls.scm ("umount, ENOENT"): Rename to... ("umount, ENOENT/EPERM"): ... this. Accept EPERM as a valid return value. --- tests/syscalls.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 5243ac9a34..ab34fc825b 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -33,13 +33,14 @@ #f) (compose system-error-errno list))) -(test-equal "umount, ENOENT" - ENOENT +(test-assert "umount, ENOENT/EPERM" (catch 'system-error (lambda () (umount "/does-not-exist") #f) - (compose system-error-errno list))) + (lambda args + ;; Both return values have been encountered in the wild. + (memv (system-error-errno args) (list EPERM ENOENT))))) (test-end) -- cgit v1.2.3