diff options
| author | Mark H Weaver <mhw@netris.org> | 2015-07-15 15:10:32 -0400 |
|---|---|---|
| committer | Mark H Weaver <mhw@netris.org> | 2015-07-15 15:10:32 -0400 |
| commit | 35995769b516d228793940c5333ad522de992a6c (patch) | |
| tree | 366b81995e9afbf8f94ecf7d4237b325ec07a0a1 | |
| parent | c6f909809aecb225b66dc27e4afd3ff46ec31a38 (diff) | |
| parent | e03f6d5e956b348c142d0ffd9f89af845f05eb86 (diff) | |
| download | guix-35995769b516d228793940c5333ad522de992a6c.tar.gz | |
Merge branch 'master' into core-updates
36 files changed, 1024 insertions, 246 deletions
diff --git a/Makefile.am b/Makefile.am index 7059a8f594..5cf9314014 100644 --- a/Makefile.am +++ b/Makefile.am @@ -203,6 +203,7 @@ SCM_TESTS = \ tests/lint.scm \ tests/publish.scm \ tests/size.scm \ + tests/file-systems.scm \ tests/containers.scm if HAVE_GUILE_JSON diff --git a/doc/guix.texi b/doc/guix.texi index 1636700429..dfe3cf38fa 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -760,6 +760,7 @@ explicitly enable substitution @i{via} the @code{set-build-options} remote procedure call (@pxref{The Store}). @item --substitute-urls=@var{urls} +@anchor{daemon-substitute-urls} Consider @var{urls} the default whitespace-separated list of substitute source URLs. When this option is omitted, @indicateurl{http://hydra.gnu.org} is used. @@ -1434,9 +1435,12 @@ also result from derivation builds, can be available as substitutes. The @code{hydra.gnu.org} server is a front-end to a build farm that builds packages from the GNU distribution continuously for some architectures, and makes them available as substitutes. This is the -default source of substitutes; it can be overridden by passing -@command{guix-daemon} the @code{--substitute-urls} option -(@pxref{Invoking guix-daemon}). +default source of substitutes; it can be overridden by passing the +@option{--substitute-urls} option either to @command{guix-daemon} +(@pxref{daemon-substitute-urls,, @code{guix-daemon --substitute-urls}}) +or to client tools such as @command{guix package} +(@pxref{client-substitute-urls,, client @option{--substitute-urls} +option}). @cindex security @cindex digital signatures @@ -3584,6 +3588,16 @@ Do not build the derivations. When substituting a pre-built binary fails, fall back to building packages locally. +@item --substitute-urls=@var{urls} +@anchor{client-substitute-urls} +Consider @var{urls} the whitespace-separated list of substitute source +URLs, overriding the default list of URLs of @command{guix-daemon} +(@pxref{daemon-substitute-urls,, @command{guix-daemon} URLs}). + +This means that substitutes may be downloaded from @var{urls}, provided +they are signed by a key authorized by the system administrator +(@pxref{Substitutes}). + @item --no-substitutes Do not use substitutes for build products. That is, always build things locally instead of allowing downloads of pre-built binaries @@ -4949,8 +4963,24 @@ interpreted as a file name; when it is @code{label}, then @code{device} is interpreted as a partition label name; when it is @code{uuid}, @code{device} is interpreted as a partition unique identifier (UUID). +UUIDs may be converted from their string representation (as shown by the +@command{tune2fs -l} command) using the @code{uuid} form, like this: + +@example +(file-system + (mount-point "/home") + (type "ext4") + (title 'uuid) + (device (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))) +@end example + The @code{label} and @code{uuid} options offer a way to refer to disk -partitions without having to hard-code their actual device name. +partitions without having to hard-code their actual device +name@footnote{Note that, while it is tempting to use +@file{/dev/disk/by-uuid} and similar device names to achieve the same +result, this is not recommended: These special device nodes are created +by the udev daemon and may be unavailable at the time the device is +mounted.}. However, when a file system's source is a mapped device (@pxref{Mapped Devices}), its @code{device} field @emph{must} refer to the mapped diff --git a/emacs/guix-emacs.el b/emacs/guix-emacs.el index 512a2e2b1a..4c3aa23115 100644 --- a/emacs/guix-emacs.el +++ b/emacs/guix-emacs.el @@ -42,19 +42,40 @@ If PROFILE is nil, use `guix-user-profile'." (expand-file-name "share/emacs/site-lisp" (or profile guix-user-profile))) +(defun guix-emacs-find-autoloads-in-directory (directory) + "Return list of Emacs 'autoloads' files in DIRECTORY." + (directory-files directory 'full-name "-autoloads\\.el\\'" 'no-sort)) + +(defun guix-emacs-subdirs (directory) + "Return list of DIRECTORY subdirectories." + (cl-remove-if (lambda (file) + (or (string-match-p (rx "/." string-end) file) + (string-match-p (rx "/.." string-end) file) + (not (file-directory-p file)))) + (directory-files directory 'full-name nil 'no-sort))) + (defun guix-emacs-find-autoloads (&optional profile) "Return list of autoloads of Emacs packages installed in PROFILE. If PROFILE is nil, use `guix-user-profile'. Return nil if there are no emacs packages installed in PROFILE." - (let ((dir (guix-emacs-directory profile))) - (if (file-directory-p dir) - (directory-files dir 'full-name "-autoloads\\.el\\'") + (let ((elisp-root-dir (guix-emacs-directory profile))) + (if (file-directory-p elisp-root-dir) + (let ((elisp-pkgs-dir (expand-file-name "guix.d" elisp-root-dir)) + (root-autoloads (guix-emacs-find-autoloads-in-directory + elisp-root-dir))) + (if (file-directory-p elisp-pkgs-dir) + (let ((pkgs-autoloads + (cl-mapcan #'guix-emacs-find-autoloads-in-directory + (guix-emacs-subdirs elisp-pkgs-dir)))) + (append root-autoloads pkgs-autoloads)) + root-autoloads)) (message "Directory '%s' does not exist." dir) nil))) ;;;###autoload (defun guix-emacs-load-autoloads (&optional all) "Load autoloads for Emacs packages installed in a user profile. +Add autoloads directories to `load-path'. If ALL is nil, activate only those packages that were installed after the last activation, otherwise activate all Emacs packages installed in `guix-user-profile'." @@ -65,6 +86,8 @@ installed in `guix-user-profile'." (cl-nset-difference autoloads guix-emacs-autoloads :test #'string=)))) (dolist (file files) + (cl-pushnew (file-name-directory file) load-path + :test #'string=) (load file 'noerror)) (setq guix-emacs-autoloads autoloads))) diff --git a/emacs/guix-info.el b/emacs/guix-info.el index bb21024c0c..f17ce01ab6 100644 --- a/emacs/guix-info.el +++ b/emacs/guix-info.el @@ -1,6 +1,7 @@ ;;; guix-info.el --- Info buffers for displaying entries -*- lexical-binding: t -*- -;; Copyright © 2014 Alex Kost <alezost@gmail.com> +;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> +;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;; This file is part of GNU Guix. @@ -482,6 +483,12 @@ If nil, insert package in a default way.") (defvar guix-package-info-heading-params '(synopsis description) "List of parameters displayed in a heading along with name and version.") +(defcustom guix-package-info-fill-heading t + "If nil, insert heading parameters in a raw form, without +filling them to fit the window." + :type 'boolean + :group 'guix-package-info) + (defun guix-package-info-insert-heading (entry) "Insert the heading for package ENTRY. Show package name, version, and `guix-package-info-heading-params'." @@ -494,8 +501,12 @@ Show package name, version, and `guix-package-info-heading-params'." (face (guix-get-symbol (symbol-name param) 'info 'package))) (when val - (guix-format-insert val (and (facep face) face)) - (insert "\n\n")))) + (let* ((col (min (window-width) fill-column)) + (val (if guix-package-info-fill-heading + (guix-get-filled-string val col) + val))) + (guix-format-insert val (and (facep face) face)) + (insert "\n\n"))))) guix-package-info-heading-params)) (defun guix-package-info-insert-with-heading (entry) diff --git a/emacs/guix-init.el.in b/emacs/guix-init.el.in index 4e40d7171a..728bc375c2 100644 --- a/emacs/guix-init.el.in +++ b/emacs/guix-init.el.in @@ -1,5 +1,4 @@ (require 'guix-autoloads) -(require 'guix-emacs) (defvar guix-load-path (replace-regexp-in-string "${prefix}" "@prefix@" "@emacsuidir@") @@ -13,9 +12,8 @@ avoid loading autoloads of Emacs packages installed in :type 'boolean :group 'guix) -(add-to-list 'load-path (guix-emacs-directory)) - (when guix-package-enable-at-startup + (require 'guix-emacs) (guix-emacs-load-autoloads 'all)) (provide 'guix-init) diff --git a/gnu-system.am b/gnu-system.am index f2f03f7892..8ee6cab573 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -86,6 +86,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/dns.scm \ gnu/packages/docbook.scm \ gnu/packages/doxygen.scm \ + gnu/packages/dunst.scm \ gnu/packages/ebook.scm \ gnu/packages/ed.scm \ gnu/packages/elf.scm \ @@ -256,6 +257,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/qemu.scm \ gnu/packages/qt.scm \ gnu/packages/ratpoison.scm \ + gnu/packages/rc.scm \ gnu/packages/rdesktop.scm \ gnu/packages/rdf.scm \ gnu/packages/readline.scm \ @@ -272,6 +274,7 @@ GNU_SYSTEM_MODULES = \ gnu/packages/search.scm \ gnu/packages/serveez.scm \ gnu/packages/shishi.scm \ + gnu/packages/skarnet.scm \ gnu/packages/skribilo.scm \ gnu/packages/slang.scm \ gnu/packages/slim.scm \ @@ -391,6 +394,7 @@ dist_patch_DATA = \ gnu/packages/patches/binutils-ld-new-dtags.patch \ gnu/packages/patches/binutils-loongson-workaround.patch \ gnu/packages/patches/bitlbee-configure-doc-fix.patch \ + gnu/packages/patches/boost-mips-avoid-m32.patch \ gnu/packages/patches/calibre-drop-unrar.patch \ gnu/packages/patches/calibre-no-updates-dialog.patch \ gnu/packages/patches/cdparanoia-fpic.patch \ diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 04431ba596..c58d23cfbd 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -22,13 +22,16 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 format) #:use-module (system foreign) #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (disk-partitions partition-label-predicate + partition-uuid-predicate find-partition-by-label + find-partition-by-uuid canonicalize-device-spec MS_RDONLY @@ -53,9 +56,10 @@ ;; 'mount' is already defined in the statically linked Guile used for initial ;; RAM disks, but in all other cases the (guix build syscalls) module contains ;; the mount binding. -(unless (defined? 'mount) - (module-use! (current-module) - (resolve-interface '(guix build syscalls)))) +(eval-when (expand load eval) + (unless (defined? 'mount) + (module-use! (current-module) + (resolve-interface '(guix build syscalls))))) ;; Linux mount flags, from libc's <sys/mount.h>. (define MS_RDONLY 1) @@ -158,29 +162,42 @@ if DEVICE does not contain an ext2 file system." (loop (cons name parts)) (loop parts)))))))))) -(define (partition-label-predicate label) - "Return a procedure that, when applied to a partition name such as \"sda1\", -return #t if that partition's volume name is LABEL." - (lambda (part) - (let* ((device (string-append "/dev/" part)) - (sblock (catch 'system-error - (lambda () - (read-ext2-superblock device)) - (lambda args - ;; When running on the hand-made /dev, - ;; 'disk-partitions' could return partitions for which - ;; we have no /dev node. Handle that gracefully. - (if (= ENOENT (system-error-errno args)) - (begin - (format (current-error-port) - "warning: device '~a' not found~%" - device) - #f) - (apply throw args)))))) - (and sblock - (let ((volume (ext2-superblock-volume-name sblock))) - (and volume - (string=? volume label))))))) +(define (read-ext2-superblock* device) + "Like 'read-ext2-superblock', but return #f when DEVICE does not exist +instead of throwing an exception." + (catch 'system-error + (lambda () + (read-ext2-superblock device)) + (lambda args + ;; When running on the hand-made /dev, + ;; 'disk-partitions' could return partitions for which + ;; we have no /dev node. Handle that gracefully. + (if (= ENOENT (system-error-errno args)) + (begin + (format (current-error-port) + "warning: device '~a' not found~%" device) + #f) + (apply throw args))))) + +(define (partition-predicate field =) + "Return a predicate that returns true if the FIELD of an ext2 superblock is += to the given value." + (lambda (expected) + "Return a procedure that, when applied to a partition name such as \"sda1\", +returns #t if that partition's volume name is LABEL." + (lambda (part) + (let* ((device (string-append "/dev/" part)) + (sblock (read-ext2-superblock* device))) + (and sblock + (let ((actual (field sblock))) + (and actual + (= actual expected)))))))) + +(define partition-label-predicate + (partition-predicate ext2-superblock-volume-name string=?)) + +(define partition-uuid-predicate + (partition-predicate ext2-superblock-uuid bytevector=?)) (define (find-partition-by-label label) "Return the first partition found whose volume name is LABEL, or #f if none @@ -189,6 +206,28 @@ were found." (disk-partitions)) (cut string-append "/dev/" <>))) +(define (find-partition-by-uuid uuid) + "Return the first partition whose unique identifier is UUID (a bytevector), +or #f if none was found." + (and=> (find (partition-uuid-predicate uuid) + (disk-partitions)) + (cut string-append "/dev/" <>))) + +(define-syntax %network-byte-order + (identifier-syntax (endianness big))) + +(define (uuid->string uuid) + "Convert UUID, a 16-byte bytevector, to its string representation, something +like \"6b700d61-5550-48a1-874c-a3d86998990e\"." + ;; See <https://tools.ietf.org/html/rfc4122>. + (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4)) + (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2)) + (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2)) + (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2)) + (node (bytevector-uint-ref uuid 10 %network-byte-order 6))) + (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x" + time-low time-mid time-hi clock-seq node))) + (define* (canonicalize-device-spec spec #:optional (title 'any)) "Return the device name corresponding to SPEC. TITLE is a symbol, one of the following: @@ -197,6 +236,8 @@ the following: \"/dev/sda1\"; • 'label', in which case SPEC is known to designate a partition label--e.g., \"my-root-part\"; + • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector) + designating a partition; • 'any', in which case SPEC can be anything. " (define max-trials @@ -209,30 +250,36 @@ the following: (define canonical-title ;; The realm of canonicalization. (if (eq? title 'any) - (if (string-prefix? "/" spec) - 'device - 'label) + (if (string? spec) + (if (string-prefix? "/" spec) + 'device + 'label) + 'uuid) title)) + (define (resolve find-partition spec fmt) + (let loop ((count 0)) + (let ((device (find-partition spec))) + (or device + ;; Some devices take a bit of time to appear, most notably USB + ;; storage devices. Thus, wait for the device to appear. + (if (> count max-trials) + (error "failed to resolve partition" (fmt spec)) + (begin + (format #t "waiting for partition '~a' to appear...~%" + (fmt spec)) + (sleep 1) + (loop (+ 1 count)))))))) + (case canonical-title ((device) ;; Nothing to do. spec) ((label) ;; Resolve the label. - (let loop ((count 0)) - (let ((device (find-partition-by-label spec))) - (or device - ;; Some devices take a bit of time to appear, most notably USB - ;; storage devices. Thus, wait for the device to appear. - (if (> count max-trials) - (error "failed to resolve partition label" spec) - (begin - (format #t "waiting for partition '~a' to appear...~%" - spec) - (sleep 1) - (loop (+ 1 count)))))))) - ;; TODO: Add support for UUIDs. + (resolve find-partition-by-label spec identity)) + ((uuid) + (resolve find-partition-by-uuid spec uuid->string)) (else (error "unknown device title" title)))) diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm index ee255b0c15..99eb95b800 100644 --- a/gnu/packages/admin.scm +++ b/gnu/packages/admin.scm @@ -480,7 +480,8 @@ tools: server, client, and relay agent.") "14wyjywrdi1ikaj6yc9c72m6m2r64z94lb0gm7k1a3q6q5cj3scs")))) (build-system gnu-build-system) (native-inputs `(("bison" ,bison) ("flex" ,flex))) - (arguments '(#:tests? #f)) ; no 'check' target + (arguments '(#:configure-flags '("--with-pcap=linux") + #:tests? #f)) ; no 'check' target (home-page "http://www.tcpdump.org") (synopsis "Network packet capture library") (description diff --git a/gnu/packages/algebra.scm b/gnu/packages/algebra.scm index 7f9fd28367..e47c405661 100644 --- a/gnu/packages/algebra.scm +++ b/gnu/packages/algebra.scm @@ -383,7 +383,7 @@ cosine/ sine transforms or DCT/DST).") (lambda _ ;; First build the tests, in parallel. ;; See <http://eigen.tuxfamily.org/index.php?title=Tests>. - (let* ((cores (current-processor-count)) + (let* ((cores (parallel-job-count)) (dash-j (format #f "-j~a" cores))) ;; These variables are supposed to be honored. (setenv "EIGEN_MAKE_ARGS" dash-j) diff --git a/gnu/packages/boost.scm b/gnu/packages/boost.scm index cb142fdb02..d3b171245d 100644 --- a/gnu/packages/boost.scm +++ b/gnu/packages/boost.scm @@ -33,7 +33,7 @@ (define-public boost (package (name "boost") - (version "1.57.0") + (version "1.58.0") (source (origin (method url-fetch) (uri (string-append @@ -42,7 +42,8 @@ ".tar.bz2")) (sha256 (base32 - "0rs94vdmg34bwwj23fllva6mhrml2i7mvmlb11zyrk1k5818q34i")))) + "1rfkqxns60171q62cppiyzj8pmsbwp1l8jd7p6crriryqd7j1z7x")) + (patches (list (search-patch "boost-mips-avoid-m32.patch"))))) (build-system gnu-build-system) (inputs `(("zlib" ,zlib))) (native-inputs diff --git a/gnu/packages/ccache.scm b/gnu/packages/ccache.scm index 2b45ab09d6..9063acb6fc 100644 --- a/gnu/packages/ccache.scm +++ b/gnu/packages/ccache.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,7 +28,7 @@ (define-public ccache (package (name "ccache") - (version "3.1.10") + (version "3.2.2") (source (origin (method url-fetch) @@ -36,16 +36,18 @@ version ".tar.xz")) (sha256 (base32 - "0mr8n1nbykxw4rs55ad8wd6xmfhihn09mxpxb91sn9mlsd1ryhw8")))) + "1jm0qb3h5sypllaiyj81zp6m009vm50hzjnx994ril94kxlrj3ag")))) (build-system gnu-build-system) (native-inputs `(("perl" ,perl))) ;for test.sh (inputs `(("zlib" ,zlib))) (arguments '(#:phases (alist-cons-before - 'check 'patch-test-shebangs + 'check 'setup-tests (lambda _ (substitute* '("test/test_hashutil.c" "test.sh") - (("#!/bin/sh") (string-append "#!" (which "sh"))))) + (("#!/bin/sh") (string-append "#!" (which "sh")))) + (setenv "SHELL" (which "sh")) + #t) %standard-phases))) (home-page "https://ccache.samba.org/") (synopsis "Compiler cache") diff --git a/gnu/packages/dunst.scm b/gnu/packages/dunst.scm new file mode 100644 index 0000000000..d5e177f0ce --- /dev/null +++ b/gnu/packages/dunst.scm @@ -0,0 +1,72 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Alex Kost <alezost@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu packages dunst) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build-system gnu) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (gnu packages base) + #:use-module (gnu packages freedesktop) + #:use-module (gnu packages glib) + #:use-module (gnu packages gtk) + #:use-module (gnu packages perl) + #:use-module (gnu packages pkg-config) + #:use-module (gnu packages xorg)) + +(define-public dunst + (package + (name "dunst") + (version "1.1.0") + (source (origin + (method url-fetch) + (uri (string-append + "http://knopwob.org/public/dunst-release/dunst-" + version ".tar.bz2")) + (sha256 + (base32 + "0w3hilzwanwsp4q6dxbdj6l0mvpg4fq02wf8isll8kmbx9kz2ay7")))) + (build-system gnu-build-system) + (arguments + '(#:tests? #f ; no check target + #:make-flags (list "CC=gcc" + (string-append "PREFIX=" %output)) + #:phases (modify-phases %standard-phases + (delete 'configure)))) + (native-inputs + `(("pkg-config" ,pkg-config) + ("perl" ,perl) ; for pod2man + ("which" ,which))) + (inputs + `(("dbus" ,dbus) + ("glib" ,glib) + ("cairo" ,cairo) + ("pango" ,pango) + ("libx11" ,libx11) + ("libxext" ,libxext) + ("libxft" ,libxft) + ("libxscrnsaver" ,libxscrnsaver) + ("libxinerama" ,libxinerama) + ("libxdg-basedir" ,libxdg-basedir))) + (home-page "http://knopwob.org/dunst") + (synopsis "Customizable and lightweight notification daemon") + (description + "Dunst is a highly configurable and minimalistic notification daemon. +It provides 'org.freedesktop.Notifications' D-Bus service, so it is +started automatically on the first call via D-Bus.") + (license license:bsd-3))) diff --git a/gnu/packages/freedesktop.scm b/gnu/packages/freedesktop.scm index eeb97cdc85..5cdb4568c5 100644 --- a/gnu/packages/freedesktop.scm +++ b/gnu/packages/freedesktop.scm @@ -91,6 +91,39 @@ freedesktop.org project.") other applications that need to directly deal with input devices.") (license license:x11))) +(define-public libxdg-basedir + (package + (name "libxdg-basedir") + (version "1.2.0") + (source (origin + (method url-fetch) + (uri (string-append + "https://github.com/devnev/libxdg-basedir/archive/" + name "-" version ".tar.gz")) + (sha256 + (base32 + "0s28c7sfwqimsmb3kn91mx7wi55fs3flhbmynl9k60rrllr00aqw")))) + (build-system gnu-build-system) + (arguments + '(#:phases + (modify-phases %standard-phases + (add-after 'unpack 'autogen + (lambda _ + ;; Run 'configure' in its own phase, not now. + (substitute* "autogen.sh" + (("^.*\\./configure.*") "")) + (zero? (system* "sh" "autogen.sh"))))))) + (native-inputs + `(("autoconf" ,autoconf) + ("automake" ,automake) + ("libtool" ,libtool))) + (home-page "https://github.com/devnev/libxdg-basedir") + (synopsis "Implementation of the XDG Base Directory specification") + (description + "libxdg-basedir is a C library providing some functions to use with +the freedesktop.org XDG Base Directory specification.") + (license license:expat))) + (define-public elogind (let ((commit "14405a9")) (package diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm index 8b88dff4dc..6aa0942674 100644 --- a/gnu/packages/gcc.scm +++ b/gnu/packages/gcc.scm @@ -27,6 +27,10 @@ #:use-module (gnu packages compression) #:use-module (gnu packages multiprecision) #:use-module (gnu packages texinfo) + #:use-module (gnu packages doxygen) + #:use-module (gnu packages xml) + #:use-module (gnu packages docbook) + #:use-module (gnu packages graphviz) #:use-module (gnu packages elf) #:use-module (gnu packages perl) #:use-module (guix packages) @@ -544,6 +548,65 @@ using compilers other than GCC." (define-public gcc-objc++-4.8 (custom-gcc gcc-4.8 "gcc-objc++" '("obj-c++"))) +(define (make-libstdc++-doc gcc) + "Return a package with the libstdc++ documentation for GCC." + (package + (inherit gcc) + (name "libstdc++-doc") + (version (package-version gcc)) + (synopsis "GNU libstdc++ documentation") + (outputs '("out")) + (native-inputs `(("doxygen" ,doxygen) + ("texinfo" ,texinfo) + ("libxml2" ,libxml2) + ("libxslt" ,libxslt) + ("docbook-xml" ,docbook-xml) + ("docbook-xsl" ,docbook-xsl) + ("graphviz" ,graphviz))) ;for 'dot', invoked by 'doxygen' + (inputs '()) + (propagated-inputs '()) + (arguments + '(#:out-of-source? #t + #:tests? #f ;it's just documentation + #:phases (modify-phases %standard-phases + (add-before 'configure 'chdir + (lambda _ + (chdir "libstdc++-v3"))) + (add-before 'configure 'set-xsl-directory + (lambda* (#:key inputs #:allow-other-keys) + (let ((docbook (assoc-ref inputs "docbook-xsl"))) + (substitute* (find-files "doc" + "^Makefile\\.in$") + (("@XSL_STYLE_DIR@") + (string-append + docbook "/xml/xsl/" + (string-drop + docbook + (+ 34 + (string-length + (%store-directory)))))))))) + (replace 'build + (lambda _ + ;; XXX: There's also a 'doc-info' target, but it + ;; relies on docbook2X, which itself relies on + ;; DocBook 4.1.2, which is not really usable + ;; (lacks a catalog.xml.) + (zero? (system* "make" + "doc-html" + "doc-man")))) + (replace 'install + (lambda* (#:key outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (zero? (system* "make" + "doc-install-html" + "doc-install-man")))))))))) + +(define-public libstdc++-doc-4.9 + (make-libstdc++-doc gcc-4.9)) + +(define-public libstdc++-doc-5.1 + (make-libstdc++-doc gcc-5.1)) + (define-public isl (package (name "isl") diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 36ba382206..2cb44f97ba 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -2090,11 +2090,12 @@ floating in an ocean using only your brain and a little bit of luck.") ("desktop-file-utils" ,desktop-file-utils) ("intltool" ,intltool) ("itstool" ,itstool))) + (propagated-inputs + `(("dconf" ,dconf))) (inputs `(("gtk+" ,gtk+) ("vte" ,vte) ("gnutls" ,gnutls) - ("dconf" ,dconf) ("gsettings-desktop-schemas" ,gsettings-desktop-schemas) ("util-linux" ,util-linux) ("vala" ,vala))) @@ -2914,3 +2915,89 @@ which can read a large number of file formats.") ;; to be used and distributed together with GStreamer and Totem. See ;; file://COPYING in the source distribution for details. (license license:gpl2+))) + +(define-public rhythmbox + (package + (name "rhythmbox") + (version "3.2.1") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnome/sources/" name "/" + (version-major+minor version) "/" + name "-" version ".tar.xz")) + (sha256 + (base32 + "0f3radhlji7rxl760yl2vm49fvfslympxrpm8497acbmbd7wlhxz")))) + (build-system glib-or-gtk-build-system) + (arguments + `(#:configure-flags + (list "--enable-lirc" + "--enable-python" + "--enable-vala" + "--with-brasero" + "--with-gudev" + "--with-libsecret") + #:phases + (modify-phases %standard-phases + (add-after + 'install 'wrap-rhythmbox + (lambda* (#:key inputs outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out")) + (gi-typelib-path (getenv "GI_TYPELIB_PATH")) + (gst-plugin-path (getenv "GST_PLUGIN_SYSTEM_PATH")) + (grl-plugin-path (getenv "GRL_PLUGIN_PATH"))) + (wrap-program (string-append out "/bin/rhythmbox") + `("GI_TYPELIB_PATH" ":" prefix (,gi-typelib-path)) + `("GST_PLUGIN_SYSTEM_PATH" ":" prefix (,gst-plugin-path)) + `("GRL_PLUGIN_PATH" ":" prefix (,grl-plugin-path)))) + #t))))) + (propagated-inputs + `(("dconf" ,dconf))) + (native-inputs + `(("intltool" ,intltool) + ("glib" ,glib "bin") + ("gobject-introspection" ,gobject-introspection) + ("desktop-file-utils" ,desktop-file-utils) + ("pkg-config" ,pkg-config))) + (inputs + `(("json-glib" ,json-glib) + ("tdb" ,tdb) + ("gnome-desktop" ,gnome-desktop) + ("python" ,python) + ("python-pygobject" ,python2-pygobject) + ("vala" ,vala) + ("gmime" ,gmime) + ("nettle" ,nettle) + ("itstool" ,itstool) + ("adwaita-icon-theme" ,adwaita-icon-theme) + ("grilo" ,grilo) + ("grilo-plugins" ,grilo-plugins) + ("gstreamer" ,gstreamer) + ("gst-plugins-base" ,gst-plugins-base) + ("gst-plugins-good" ,gst-plugins-good) + ("eudev" ,eudev) + ("totem-pl-parser" ,totem-pl-parser) + ;;("libmtp" ,libmtp) FIXME: Not detected + ("libsecret" ,libsecret) + ("libsoup" ,libsoup) + ("libnotify" ,libnotify) + ("libpeas" ,libpeas) + ("lirc" ,lirc) + ;; TODO: clutter* only used by visualizer plugin, which also requires mx + ;;("clutter" ,clutter) + ;;("clutter-gtk" ,clutter-gtk) + ;;("clutter-gst" ,clutter-gst) + ("gsettings-desktop-schemas" ,gsettings-desktop-schemas) + ("atk" ,atk) + ("pango" ,pango) + ("gtk+" ,gtk+) + ;; TODO: + ;; * libgpod + ;; * mx + ;; * webkit + ("brasero" ,brasero))) + (home-page "https://wiki.gnome.org/Apps/Rhythmbox") + (synopsis "Music player for GNOME") + (description "Rhythmbox is a music playing application for GNOME. It +supports playlists, song ratings, and any codecs installed through gstreamer.") + (license license:gpl2+))) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index c5d055366e..03f933c2df 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -210,7 +210,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM." #f))) (define-public linux-libre - (let* ((version "4.1.1") + (let* ((version "4.1.2") (build-phase '(lambda* (#:key system inputs #:allow-other-keys #:rest args) ;; Apply the neat patch. @@ -283,7 +283,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM." (uri (linux-libre-urls version)) (sha256 (base32 - "12fdrawzjqhlmjvw79iy9419pf7m3k29xcjri57i4ynaf3yfzkk0")))) + "0clgjpcw1xzqa7jpm6k5fafg3wnc28mzyar3xgr4vbm6zb61fl7k")))) (build-system gnu-build-system) (native-inputs `(("perl" ,perl) ("bc" ,bc) diff --git a/gnu/packages/music.scm b/gnu/packages/music.scm index 9e7e0126c0..13ddd8b338 100644 --- a/gnu/packages/music.scm +++ b/gnu/packages/music.scm @@ -424,7 +424,14 @@ Editor. It is compatible with Power Tab Editor 1.7 and Guitar Pro.") (list (string-append "PREFIX=" (assoc-ref %outputs "out")) (string-append "FONTFILE=" (assoc-ref %build-inputs "font-bitstream-vera") - "/share/fonts/truetype/VeraBd.ttf")) + "/share/fonts/truetype/VeraBd.ttf") + ;; Disable unsupported optimization flags on non-x86 + ,@(let ((system (or (%current-target-system) + (%current-system)))) + (if (or (string-prefix? "x86_64" system) + (string-prefix? "i686" system)) + '() + '("OPTIMIZATIONS=-ffast-math -fomit-frame-pointer -O3")))) #:phases (modify-phases %standard-phases (add-before 'build 'set-CC-variable diff --git a/gnu/packages/ntp.scm b/gnu/packages/ntp.scm index d4a12e37c9..e2b43e91d7 100644 --- a/gnu/packages/ntp.scm +++ b/gnu/packages/ntp.scm @@ -24,6 +24,7 @@ #:use-module (gnu packages linux) #:use-module (gnu packages pkg-config) #:use-module (gnu packages tls) + #:use-module (gnu packages libevent) #:use-module ((guix licenses) #:prefix l:) #:use-module (guix packages) #:use-module (guix utils) @@ -34,7 +35,7 @@ (define-public ntp (package (name "ntp") - (version "4.2.8p2") + (version "4.2.8p3") (source (origin (method url-fetch) (uri (string-append @@ -43,17 +44,39 @@ "/ntp-" version ".tar.gz")) (sha256 (base32 - "0ccv9kh5asxpk7bjn73vwrqimbkbfl743bgx0km47bfajl7bqs8d")))) + "13zkzcvjm5kbxl4xbcmaq07slplhmpkgahzcqnqlba3cxpra9341")) + (modules '((guix build utils))) + (snippet + '(begin + ;; Remove the bundled copy of libevent, but we must keep + ;; sntp/libevent/build-aux since configure.ac contains + ;; AC_CONFIG_AUX_DIR([sntp/libevent/build-aux]) + (rename-file "sntp/libevent/build-aux" + "sntp/libevent:build-aux") + (delete-file-recursively "sntp/libevent") + (mkdir "sntp/libevent") + (rename-file "sntp/libevent:build-aux" + "sntp/libevent/build-aux") + #t)))) (native-inputs `(("which" ,which) ("pkg-config" ,pkg-config))) (inputs `(("openssl" ,openssl) + ("libevent" ,libevent) ;; Build with POSIX capabilities support on GNU/Linux. This allows 'ntpd' ;; to run as non-root (when invoked with '-u'.) ,@(if (string-suffix? "-linux" (or (%current-target-system) (%current-system))) `(("libcap" ,libcap)) '()))) + (arguments + `(#:phases + (modify-phases %standard-phases + (add-after 'unpack 'disable-network-test + (lambda _ + (substitute* "tests/libntp/Makefile.in" + (("test-decodenetnum\\$\\(EXEEXT\\) ") "")) + #t))))) (build-system gnu-build-system) (synopsis "Real time clock synchonization system") (description "NTP is a system designed to synchronize the clocks of diff --git a/gnu/packages/patches/boost-mips-avoid-m32.patch b/gnu/packages/patches/boost-mips-avoid-m32.patch new file mode 100644 index 0000000000..811c9fb3aa --- /dev/null +++ b/gnu/packages/patches/boost-mips-avoid-m32.patch @@ -0,0 +1,15 @@ +The following patch prevents the use of the -m32 flag on mips, where it +is not understood by gcc, as well as other non-x86 architectures. + +diff -u -r boost_1_58_0.orig/tools/build/src/tools/gcc.jam boost_1_58_0/tools/build/src/tools/gcc.jam +--- boost_1_58_0.orig/tools/build/src/tools/gcc.jam 2015-04-04 19:25:07.000000000 +0200 ++++ boost_1_58_0/tools/build/src/tools/gcc.jam 2015-07-10 01:08:19.822733823 +0200 +@@ -451,7 +451,7 @@ + else + { + local arch = [ feature.get-values architecture : $(properties) ] ; +- if $(arch) != arm ++ if $(arch) = x86 + { + if $(model) = 32 + { diff --git a/gnu/packages/polkit.scm b/gnu/packages/polkit.scm index be7302ed49..172b0e128d 100644 --- a/gnu/packages/polkit.scm +++ b/gnu/packages/polkit.scm @@ -35,7 +35,7 @@ (define-public polkit (package (name "polkit") - (version "0.112") + (version "0.113") (source (origin (method url-fetch) (uri (string-append @@ -43,7 +43,7 @@ name "-" version ".tar.gz")) (sha256 (base32 - "1xkary7yirdcjdva950nqyhmsz48qhrdsr78zciahj27p8yg95fn")) + "109w86kfqrgz83g9ivggplmgc77rz8kx8646izvm2jb57h4rbh71")) (patches (list (search-patch "polkit-drop-test.patch"))))) (build-system gnu-build-system) (inputs diff --git a/gnu/packages/pumpio.scm b/gnu/packages/pumpio.scm index 4a6375f3f2..22c631edf9 100644 --- a/gnu/packages/pumpio.scm +++ b/gnu/packages/pumpio.scm @@ -30,15 +30,15 @@ (define-public pumpa (package (name "pumpa") - (version "0.9") + (version "0.9.1") (source (origin (method git-fetch) ; no source tarballs (uri (git-reference - (url "https://gitorious.org/pumpa/pumpa.git") + (url "git://pumpa.branchable.com/") (commit (string-append "v" version)))) (sha256 (base32 - "0v55xq17wnc9mvpmrm5r3rjrsg9npnjv1lznbz8ppk77ba8pwimy")))) + "14s0m46yqph8bs5rjpmiq42f020j9l3mygan2zj93z6qzypwd07f")))) (build-system gnu-build-system) (arguments '(#:phases (alist-replace diff --git a/gnu/packages/rc.scm b/gnu/packages/rc.scm new file mode 100644 index 0000000000..d3edf9e997 --- /dev/null +++ b/gnu/packages/rc.scm @@ -0,0 +1,72 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Jeff Mickey <j@codemac.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu packages rc) + #:use-module (gnu packages autotools) + #:use-module (gnu packages perl) + #:use-module (gnu packages pkg-config) + #:use-module (gnu packages readline) + #:use-module (guix build-system gnu) + #:use-module (guix git-download) + #:use-module (guix licenses) + #:use-module (guix packages)) + +(define-public rc + (package + (name "rc") + (version "1.7.4") + (source (origin + (method git-fetch) + (uri (git-reference + (url "git://github.com/rakitzis/rc.git") + ;; commit name 'release: rc-1.7.4' + (commit "c884da53a7c885d46ace2b92de78946855b18e92"))) + (sha256 + (base32 + "00mgzvrrh9w96xa85g4gjbsvq02f08k4jwjcdnxq7kyh5xgiw95l")) + (file-name (string-append name "-" version "-checkout")))) + (build-system gnu-build-system) + (arguments + `(#:configure-flags + '("--with-edit=gnu") + #:phases + (modify-phases %standard-phases + (add-after + 'unpack 'autoreconf + (lambda _ (zero? (system* "autoreconf" "-vfi")))) + (add-before + 'autoreconf 'patch-trip.rc + (lambda _ + (substitute* "trip.rc" + (("/bin/pwd") (which "pwd")) + (("/bin/sh") (which "sh")) + (("/bin/rm") (which "rm")) + (("/bin\\)") (string-append (dirname (which "rm")) ")"))) + #t))))) + (inputs `(("readline" ,readline) + ("perl" ,perl))) + (native-inputs `(("autoconf" ,autoconf) + ("automake" ,automake) + ("libtool" ,libtool) + ("pkg-config" ,pkg-config))) + (synopsis "Alternative implementation of the rc shell by Byron Rakitzis") + (description + "This is a reimplementation by Byron Rakitzis of the Plan 9 shell. It +has a small feature set similar to a traditional Bourne shell.") + (home-page "http://github.com/rakitzis/rc") + (license zlib))) diff --git a/gnu/packages/skarnet.scm b/gnu/packages/skarnet.scm new file mode 100644 index 0000000000..e1518feeb4 --- /dev/null +++ b/gnu/packages/skarnet.scm @@ -0,0 +1,92 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Claes Wallin <claes.wallin@greatsinodevelopment.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu packages skarnet) + #:use-module (gnu packages) + #:use-module (guix licenses) + #:use-module (guix packages) + #:use-module (guix download) + #:use-module (guix build-system gnu)) + +(define-public skalibs + (package + (name "skalibs") + (version "2.3.5.1") + (source + (origin + (method url-fetch) + (uri (string-append "http://skarnet.org/software/skalibs/skalibs-" + version ".tar.gz")) + (sha256 + (base32 + "1m31wph4qr4mqgv51nzwd9nw0x5vmpkcxr48i216wn3dpy3mvxwy")))) + (build-system gnu-build-system) + (arguments + '(#:configure-flags '("--enable-force-devr") ; do not analyze /dev/random + #:tests? #f)) ; no tests exist + (home-page "http://skarnet.org/software/skalibs/") + (synopsis "Platform abstraction libraries for skarnet.org software") + (description + "This package provides lightweight C libraries isolating the developer +from portability issues, providing a unified systems API on all platforms, +including primitive data types, cryptography, and POSIX concepts like sockets +and file system operations. It is used by all skarnet.org software.") + (license isc))) + +(define-public execline + (package + (name "execline") + (version "2.1.2.2") + (source + (origin + (method url-fetch) + (uri (string-append "http://skarnet.org/software/execline/execline-" + version ".tar.gz")) + (sha256 + (base32 + "01pckac5zijf6icrhwicbmq92yq68gfkf1yl03rr2v4q3cn8r85f")))) + (build-system gnu-build-system) + (inputs `(("skalibs" ,skalibs))) + (arguments + '(#:configure-flags (list + (string-append "--with-lib=" + (assoc-ref %build-inputs "skalibs") + "/lib/skalibs") + (string-append "--with-sysdeps=" + (assoc-ref %build-inputs "skalibs") + "/lib/skalibs/sysdeps")) + #:phases (modify-phases %standard-phases + (add-after + 'install 'post-install + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin (string-append out "/bin"))) + (wrap-program (string-append bin "/execlineb") + `("PATH" ":" prefix (,bin))))))) + #:tests? #f)) ; No tests exist. + (home-page "http://skarnet.org/software/execline/") + (license isc) + (synopsis "Non-interactive shell-like language with minimal overhead") + (description + "Execline is a (non-interactive) scripting language, separated into a +parser (execlineb) and a set of commands meant to execute one another in a +chain-execution fashion, storing the whole script in the argument array. +It features conditional loops, getopt-style option handling, file name +globbing, redirection and other shell concepts, expressed as discrete commands +rather than in special syntax, minimizing runtime footprint and +complexity."))) diff --git a/gnu/packages/ssh.scm b/gnu/packages/ssh.scm index 5d44b07f97..a827aa1d90 100644 --- a/gnu/packages/ssh.scm +++ b/gnu/packages/ssh.scm @@ -122,16 +122,18 @@ a server that supports the SSH-2 protocol.") (define-public openssh (package (name "openssh") - (version "6.8p1") + (version "6.9p1") (source (origin (method url-fetch) (uri (let ((tail (string-append name "-" version ".tar.gz"))) - (list (string-append "ftp://ftp.fr.openbsd.org/pub/OpenBSD/OpenSSH/portable/" + (list (string-append "http://openbsd.cs.fau.de/pub/OpenBSD/OpenSSH/portable/" tail) - (string-append "ftp://ftp2.fr.openbsd.org/pub/OpenBSD/OpenSSH/portable/" + (string-append "http://ftp.fr.openbsd.org/pub/OpenBSD/OpenSSH/portable/" + tail) + (string-append "http://ftp2.fr.openbsd.org/pub/OpenBSD/OpenSSH/portable/" tail)))) (sha256 (base32 - "03hnrqvjq6ghg1mp3gkarfxh6g3x1n1vjrzpbc5lh9717vklrxiz")))) + "1zkci5nbpb4frmzj2vr3kv9j47x2h72kvybcpr0d8mzk73sls1vf")))) (build-system gnu-build-system) (inputs `(("groff" ,groff) ("openssl" ,openssl) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index a06c173a70..ece8fb41e6 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -18,9 +18,13 @@ (define-module (gnu system file-systems) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (guix gexp) #:use-module (guix records) #:use-module (guix store) + #:use-module (rnrs bytevectors) + #:use-module ((gnu build file-systems) #:select (uuid->string)) + #:re-export (uuid->string) #:export (<file-system> file-system file-system? @@ -35,6 +39,8 @@ file-system-create-mount-point? file-system->spec + string->uuid + uuid %fuse-control-file-system %binary-format-file-system @@ -106,6 +112,57 @@ initrd code." (($ <file-system> device title mount-point type flags options _ check?) (list device title mount-point type flags options check?)))) +(define %uuid-rx + ;; The regexp of a UUID. + (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$")) + +(define (string->uuid str) + "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and +return its contents as a 16-byte bytevector. Return #f if STR is not a valid +UUID representation." + (and=> (regexp-exec %uuid-rx str) + (lambda (match) + (letrec-syntax ((hex->number + (syntax-rules () + ((_ index) + (string->number (match:substring match index) + 16)))) + (put! + (syntax-rules () + ((_ bv index (number len) rest ...) + (begin + (bytevector-uint-set! bv index number + (endianness big) len) + (put! bv (+ index len) rest ...))) + ((_ bv index) + bv)))) + (let ((time-low (hex->number 1)) + (time-mid (hex->number 2)) + (time-hi (hex->number 3)) + (clock-seq (hex->number 4)) + (node (hex->number 5)) + (uuid (make-bytevector 16))) + (put! uuid 0 + (time-low 4) (time-mid 2) (time-hi 2) + (clock-seq 2) (node 6))))))) + +(define-syntax uuid + (lambda (s) + "Return the bytevector corresponding to the given UUID representation." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + ;; A literal string: do the conversion at expansion time. + (with-syntax ((bv (string->uuid (syntax->datum #'str)))) + #''bv)) + ((_ str) + #'(string->uuid str))))) + + +;;; +;;; Common file systems. +;;; + (define %fuse-control-file-system ;; Control file system for Linux' file systems in user-space (FUSE). (file-system @@ -208,7 +265,7 @@ initrd code." ;; https://github.com/docker/libcontainer/blob/master/SPEC.md#filesystem (define %container-file-systems (list - ;; Psuedo-terminal file system. + ;; Pseudo-terminal file system. (file-system (device "none") (mount-point "/dev/pts") diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 6f4116ef9b..359d1265e5 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -342,7 +342,7 @@ Use Alt-F2 for documentation. parted ddrescue grub ;mostly so xrefs to its manual work cryptsetup - wireless-tools iw wpa-supplicant-light + wireless-tools iw wpa-supplicant-light iproute ;; XXX: We used to have GNU fdisk here, but as of version ;; 2.0.0a, that pulls Guile 1.8, which takes unreasonable ;; space; furthermore util-linux's fdisk is already diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 7fd05da189..d593b5a8a7 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -118,6 +118,9 @@ options handled by 'set-build-options-from-command-line', and listed in (display (_ " --no-substitutes build instead of resorting to pre-built substitutes")) (display (_ " + --substitute-urls=URLS + fetch substitute from URLS if they are authorized")) + (display (_ " --no-build-hook do not attempt to offload builds via the build hook")) (display (_ " --max-silent-time=SECONDS @@ -141,6 +144,8 @@ options handled by 'set-build-options-from-command-line', and listed in #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1) #:fallback? (assoc-ref opts 'fallback?) #:use-substitutes? (assoc-ref opts 'substitutes?) + #:substitute-urls (or (assoc-ref opts 'substitute-urls) + %default-substitute-urls) #:use-build-hook? (assoc-ref opts 'build-hook?) #:max-silent-time (assoc-ref opts 'max-silent-time) #:timeout (assoc-ref opts 'timeout) @@ -177,6 +182,13 @@ options handled by 'set-build-options-from-command-line', and listed in (alist-cons 'substitutes? #f (alist-delete 'substitutes? result)) rest))) + (option '("substitute-urls") #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'substitute-urls + (string-tokenize arg) + (alist-delete 'substitute-urls result)) + rest))) (option '("no-build-hook") #f #f (lambda (opt name arg result . rest) (apply values diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 3740b71d5e..6dc5b68f95 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -34,8 +34,6 @@ #:use-module (ice-9 regex) #:use-module (ice-9 format) #:use-module (web uri) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module ((guix build download) #:select (maybe-expand-mirrors open-connection-for-uri)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 0baba91981..95aae2a372 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -25,6 +25,7 @@ #:use-module (guix records) #:use-module (guix serialization) #:use-module (guix hash) + #:use-module (guix base32) #:use-module (guix base64) #:use-module (guix pk-crypto) #:use-module (guix pki) @@ -184,37 +185,29 @@ to the caller without emitting an error message." (setvbuf port _IONBF))) (http-fetch uri #:text? #f #:port port)))))))) -(define-record-type <cache> - (%make-cache url store-directory wants-mass-query?) - cache? - (url cache-url) - (store-directory cache-store-directory) - (wants-mass-query? cache-wants-mass-query?)) - -(define (open-cache url) - "Open the binary cache at URL. Return a <cache> object on success, or #f on -failure." - (define (download-cache-info url) +(define-record-type <cache-info> + (%make-cache-info url store-directory wants-mass-query?) + cache-info? + (url cache-info-url) + (store-directory cache-info-store-directory) + (wants-mass-query? cache-info-wants-mass-query?)) + +(define (download-cache-info url) + "Download the information for the cache at URL. Return a <cache-info> +object on success, or #f on failure." + (define (download url) ;; Download the `nix-cache-info' from URL, and return its contents as an ;; list of key/value pairs. (and=> (false-if-exception (fetch (string->uri url))) fields->alist)) - (and=> (download-cache-info (string-append url "/nix-cache-info")) + (and=> (download (string-append url "/nix-cache-info")) (lambda (properties) (alist->record properties - (cut %make-cache url <...>) + (cut %make-cache-info url <...>) '("StoreDir" "WantMassQuery"))))) -(define-syntax-rule (open-cache* url) - "Delayed variant of 'open-cache' that also lets the user know that they're -gonna have to wait." - (delay (begin - (format (current-error-port) - (_ "updating list of substitutes from '~a'...\r") - url) - (open-cache url)))) - + (define-record-type <narinfo> (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size references deriver system signature contents) @@ -379,20 +372,23 @@ the cache STR originates form." (make-time time-monotonic 0 date))) -(define (narinfo-cache-file path) - "Return the name of the local file that contains an entry for PATH." +(define (narinfo-cache-file cache-url path) + "Return the name of the local file that contains an entry for PATH. The +entry is stored in a sub-directory specific to CACHE-URL." (string-append %narinfo-cache-directory "/" - (store-path-hash-part path))) - -(define (cached-narinfo path) - "Check locally if we have valid info about PATH. Return two values: a -Boolean indicating whether we have valid cached info, and that info, which may -be either #f (when PATH is unavailable) or the narinfo for PATH." + (bytevector->base32-string (sha256 (string->utf8 cache-url))) + "/" (store-path-hash-part path))) + +(define (cached-narinfo cache-url path) + "Check locally if we have valid info about PATH coming from CACHE-URL. +Return two values: a Boolean indicating whether we have valid cached info, and +that info, which may be either #f (when PATH is unavailable) or the narinfo +for PATH." (define now (current-time time-monotonic)) (define cache-file - (narinfo-cache-file path)) + (narinfo-cache-file cache-url path)) (catch 'system-error (lambda () @@ -418,9 +414,9 @@ be either #f (when PATH is unavailable) or the narinfo for PATH." (lambda _ (values #f #f)))) -(define (cache-narinfo! cache path narinfo) - "Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may -be #f, in which case it indicates that PATH is unavailable at CACHE." +(define (cache-narinfo! cache-url path narinfo) + "Cache locally NARNIFO for PATH, which originates from CACHE-URL. NARINFO +may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." (define now (current-time time-monotonic)) @@ -430,9 +426,12 @@ be #f, in which case it indicates that PATH is unavailable at CACHE." (date ,(time-second now)) (value ,(and=> narinfo narinfo->string)))) - (with-atomic-file-output (narinfo-cache-file path) - (lambda (out) - (write (cache-entry (cache-url cache) narinfo) out))) + (let ((file (narinfo-cache-file cache-url path))) + (mkdir-p (dirname file)) + (with-atomic-file-output file + (lambda (out) + (write (cache-entry cache-url narinfo) out)))) + narinfo) (define (narinfo-request cache-url path) @@ -491,11 +490,8 @@ if file doesn't exist, and the narinfo otherwise." #f (apply throw args))))) -(define (fetch-narinfos cache paths) - "Retrieve all the narinfos for PATHS from CACHE and return them." - (define url - (cache-url cache)) - +(define (fetch-narinfos url paths) + "Retrieve all the narinfos for PATHS from the cache at URL and return them." (define update-progress! (let ((done 0)) (lambda () @@ -513,7 +509,7 @@ if file doesn't exist, and the narinfo otherwise." (case (response-code response) ((200) ; hit (let ((narinfo (read-narinfo port url #:size len))) - (cache-narinfo! cache (narinfo-path narinfo) narinfo) + (cache-narinfo! url (narinfo-path narinfo) narinfo) (update-progress!) narinfo)) ((404) ; failure @@ -522,7 +518,7 @@ if file doesn't exist, and the narinfo otherwise." (if len (get-bytevector-n port len) (read-to-eof port)) - (cache-narinfo! cache + (cache-narinfo! url (find (cut string-contains <> hash-part) paths) #f) (update-progress!)) @@ -533,7 +529,12 @@ if file doesn't exist, and the narinfo otherwise." (read-to-eof port)) #f)))) - (and (string=? (cache-store-directory cache) (%store-prefix)) + (define cache-info + (download-cache-info url)) + + (and cache-info + (string=? (cache-info-store-directory cache-info) + (%store-prefix)) (let ((uri (string->uri url))) (case (and=> uri uri-scheme) ((http) @@ -559,7 +560,7 @@ information is available locally." (let-values (((cached missing) (fold2 (lambda (path cached missing) (let-values (((valid? value) - (cached-narinfo path))) + (cached-narinfo cache path))) (if valid? (values (cons value cached) missing) (values cached (cons path missing))))) @@ -568,11 +569,8 @@ information is available locally." paths))) (if (null? missing) cached - (let* ((cache (force cache)) - (missing (if cache - (fetch-narinfos cache missing) - '()))) - (append cached missing))))) + (let ((missing (fetch-narinfos cache missing))) + (append cached (or missing '())))))) (define (lookup-narinfo cache path) "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was @@ -580,8 +578,8 @@ found." (match (lookup-narinfos cache (list path)) ((answer) answer))) -(define (remove-expired-cached-narinfos) - "Remove expired narinfo entries from the cache. The sole purpose of this +(define (remove-expired-cached-narinfos directory) + "Remove expired narinfo entries from DIRECTORY. The sole purpose of this function is to make sure `%narinfo-cache-directory' doesn't grow indefinitely." (define now @@ -605,16 +603,25 @@ indefinitely." #t))) (for-each (lambda (file) - (let ((file (string-append %narinfo-cache-directory - "/" file))) + (let ((file (string-append directory "/" file))) (when (expired? file) ;; Wrap in `false-if-exception' because FILE might have been ;; deleted in the meantime (TOCTTOU). (false-if-exception (delete-file file))))) - (scandir %narinfo-cache-directory + (scandir directory (lambda (file) (= (string-length file) 32))))) +(define (narinfo-cache-directories) + "Return the list of narinfo cache directories (one per cache URL.)" + (map (cut string-append %narinfo-cache-directory "/" <>) + (scandir %narinfo-cache-directory + (lambda (item) + (and (not (member item '("." ".."))) + (file-is-directory? + (string-append %narinfo-cache-directory + "/" item))))))) + (define (maybe-remove-expired-cached-narinfo) "Remove expired narinfo entries from the cache if deemed necessary." (define now @@ -628,8 +635,10 @@ indefinitely." (call-with-input-file expiry-file read)) 0)) - (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay) - (remove-expired-cached-narinfos) + (when (obsolete? last-expiry-date now + %narinfo-expired-cache-entry-removal-delay) + (for-each remove-expired-cached-narinfos + (narinfo-cache-directories)) (call-with-output-file expiry-file (cute write (time-second now) <>)))) @@ -690,6 +699,95 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;;; +;;; Daemon/substituter protocol. +;;; + +(define (display-narinfo-data narinfo) + "Write to the current output port the contents of NARINFO is the format +expected by the daemon." + (format #t "~a\n~a\n~a\n" + (narinfo-path narinfo) + (or (and=> (narinfo-deriver narinfo) + (cute string-append (%store-prefix) "/" <>)) + "") + (length (narinfo-references narinfo))) + (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) + (narinfo-references narinfo)) + (format #t "~a\n~a\n" + (or (narinfo-file-size narinfo) 0) + (or (narinfo-size narinfo) 0))) + +(define* (process-query command + #:key cache-url acl) + "Reply to COMMAND, a query as written by the daemon to this process's +standard input. Use ACL as the access-control list against which to check +authorized substitutes." + (define (valid? obj) + (and (narinfo? obj) (valid-narinfo? obj acl))) + + (match (string-tokenize command) + (("have" paths ..1) + ;; Return the subset of PATHS available in CACHE-URL. + (let ((substitutable (lookup-narinfos cache-url paths))) + (for-each (lambda (narinfo) + (format #t "~a~%" (narinfo-path narinfo))) + (filter valid? substitutable)) + (newline))) + (("info" paths ..1) + ;; Reply info about PATHS if it's in CACHE-URL. + (let ((substitutable (lookup-narinfos cache-url paths))) + (for-each display-narinfo-data (filter valid? substitutable)) + (newline))) + (wtf + (error "unknown `--query' command" wtf)))) + +(define* (process-substitution store-item destination + #:key cache-url acl) + "Substitute STORE-ITEM (a store file name) from CACHE-URL, and write it to +DESTINATION as a nar file. Verify the substitute against ACL." + (let* ((narinfo (lookup-narinfo cache-url store-item)) + (uri (narinfo-uri narinfo))) + ;; Make sure it is signed and everything. + (assert-valid-narinfo narinfo acl) + + ;; Tell the daemon what the expected hash of the Nar itself is. + (format #t "~a~%" (narinfo-hash narinfo)) + + (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%" + store-item + + ;; Use the Nar size as an estimate of the installed size. + (narinfo-size narinfo) + (and=> (narinfo-size narinfo) + (cute / <> (expt 2. 20)))) + (let*-values (((raw download-size) + ;; Note that Hydra currently generates Nars on the fly + ;; and doesn't specify a Content-Length, so + ;; DOWNLOAD-SIZE is #f in practice. + (fetch uri #:buffered? #f #:timeout? #f)) + ((progress) + (let* ((comp (narinfo-compression narinfo)) + (dl-size (or download-size + (and (equal? comp "none") + (narinfo-size narinfo)))) + (progress (progress-proc (uri-abbreviation uri) + dl-size + (current-error-port)))) + (progress-report-port progress raw))) + ((input pids) + (decompressed-port (and=> (narinfo-compression narinfo) + string->symbol) + progress))) + ;; Unpack the Nar at INPUT into DESTINATION. + (restore-file input destination) + + ;; Skip a line after what 'progress-proc' printed. + (newline (current-error-port)) + + (every (compose zero? cdr waitpid) pids)))) + + +;;; ;;; Entry point. ;;; @@ -737,12 +835,15 @@ substitutes may be unavailable\n"))))) found." (assoc-ref (daemon-options) option)) +(define-syntax-rule (or* a b) + (let ((first a)) + (if (or (not first) (string-null? first)) + b + first))) + (define %cache-url - (match (and=> ;; TODO: Uncomment the following lines when multiple - ;; substitute sources are supported. - ;; (find-daemon-option "untrusted-substitute-urls") ;client - ;; " " - (find-daemon-option "substitute-urls") ;admin + (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client + (find-daemon-option "substitute-urls")) ;admin string-tokenize) ((url) url) @@ -788,94 +889,19 @@ substituter disabled~%") (with-error-handling ; for signature errors (match args (("--query") - (let ((cache (open-cache* %cache-url)) - (acl (current-acl))) - (define (valid? obj) - (and (narinfo? obj) (valid-narinfo? obj acl))) - + (let ((acl (current-acl))) (let loop ((command (read-line))) (or (eof-object? command) (begin - (match (string-tokenize command) - (("have" paths ..1) - ;; Return the subset of PATHS available in CACHE. - (let ((substitutable - (if cache - (lookup-narinfos cache paths) - '()))) - (for-each (lambda (narinfo) - (format #t "~a~%" (narinfo-path narinfo))) - (filter valid? substitutable)) - (newline))) - (("info" paths ..1) - ;; Reply info about PATHS if it's in CACHE. - (let ((substitutable - (if cache - (lookup-narinfos cache paths) - '()))) - (for-each (lambda (narinfo) - (format #t "~a\n~a\n~a\n" - (narinfo-path narinfo) - (or (and=> (narinfo-deriver narinfo) - (cute string-append - (%store-prefix) "/" - <>)) - "") - (length (narinfo-references narinfo))) - (for-each (cute format #t "~a/~a~%" - (%store-prefix) <>) - (narinfo-references narinfo)) - (format #t "~a\n~a\n" - (or (narinfo-file-size narinfo) 0) - (or (narinfo-size narinfo) 0))) - (filter valid? substitutable)) - (newline))) - (wtf - (error "unknown `--query' command" wtf))) + (process-query command + #:cache-url %cache-url + #:acl acl) (loop (read-line))))))) (("--substitute" store-path destination) ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. - (let* ((cache (open-cache* %cache-url)) - (narinfo (lookup-narinfo cache store-path)) - (uri (narinfo-uri narinfo))) - ;; Make sure it is signed and everything. - (assert-valid-narinfo narinfo) - - ;; Tell the daemon what the expected hash of the Nar itself is. - (format #t "~a~%" (narinfo-hash narinfo)) - - (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%" - store-path - - ;; Use the Nar size as an estimate of the installed size. - (narinfo-size narinfo) - (and=> (narinfo-size narinfo) - (cute / <> (expt 2. 20)))) - (let*-values (((raw download-size) - ;; Note that Hydra currently generates Nars on the fly - ;; and doesn't specify a Content-Length, so - ;; DOWNLOAD-SIZE is #f in practice. - (fetch uri #:buffered? #f #:timeout? #f)) - ((progress) - (let* ((comp (narinfo-compression narinfo)) - (dl-size (or download-size - (and (equal? comp "none") - (narinfo-size narinfo)))) - (progress (progress-proc (uri-abbreviation uri) - dl-size - (current-error-port)))) - (progress-report-port progress raw))) - ((input pids) - (decompressed-port (and=> (narinfo-compression narinfo) - string->symbol) - progress))) - ;; Unpack the Nar at INPUT into DESTINATION. - (restore-file input destination) - - ;; Skip a line after what 'progress-proc' printed. - (newline (current-error-port)) - - (every (compose zero? cdr waitpid) pids)))) + (process-substitution store-path destination + #:cache-url %cache-url + #:acl (current-acl))) (("--version") (show-version-and-exit "guix substitute")) (("--help") @@ -883,7 +909,6 @@ substituter disabled~%") (opts (leave (_ "~a: unrecognized options~%") opts)))))) - ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; End: diff --git a/guix/store.scm b/guix/store.scm index 39e5faf6c8..132b8a3ac4 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -37,6 +37,7 @@ #:use-module (ice-9 popen) #:export (%daemon-socket-file %gc-roots-directory + %default-substitute-urls nix-server? nix-server-major-version diff --git a/guix/tests.scm b/guix/tests.scm index 16b8cc7f8a..cd8eda2f60 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -36,6 +36,7 @@ network-reachable? shebang-too-long? mock + %test-substitute-urls %substitute-directory with-derivation-narinfo with-derivation-substitute @@ -49,6 +50,12 @@ ;;; ;;; Code: +(define %test-substitute-urls + ;; URLs where to look for substitutes during tests. + (make-parameter + (or (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") list) + '()))) + (define (open-connection-for-tests) "Open a connection to the build daemon for tests purposes and return it." (guard (c ((nix-error? c) @@ -57,7 +64,9 @@ #f)) (let ((store (open-connection))) ;; Make sure we build everything by ourselves. - (set-build-options store #:use-substitutes? #f) + (set-build-options store + #:use-substitutes? #f + #:substitute-urls (%test-substitute-urls)) ;; Use the bootstrap Guile when running tests, so we don't end up ;; building everything in the temporary test store. diff --git a/tests/derivations.scm b/tests/derivations.scm index f66ef5cdd7..d2a090c8bc 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -612,7 +612,8 @@ (output (derivation->output-path drv))) ;; Make sure substitutes are usable. - (set-build-options store #:use-substitutes? #t) + (set-build-options store #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) (with-derivation-narinfo drv (let-values (((build download) @@ -634,7 +635,8 @@ (output (derivation->output-path drv))) ;; Make sure substitutes are usable. - (set-build-options store #:use-substitutes? #t) + (set-build-options store #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) (with-derivation-narinfo drv (let-values (((build download) @@ -655,7 +657,8 @@ (output (derivation->output-path drv))) ;; Make sure substitutes are usable. - (set-build-options store #:use-substitutes? #t) + (set-build-options store #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) (with-derivation-narinfo drv (let-values (((build download) diff --git a/tests/file-systems.scm b/tests/file-systems.scm new file mode 100644 index 0000000000..d445b4971f --- /dev/null +++ b/tests/file-systems.scm @@ -0,0 +1,46 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-file-systems) + #:use-module (gnu system file-systems) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors)) + +;; Test the (gnu system file-systems) module. + +(test-begin "file-systems") + +(test-equal "uuid->string" + "c5307e6b-d1ba-499d-89c5-cb0b143577c4" + (uuid->string + #vu8(197 48 126 107 209 186 73 157 137 197 203 11 20 53 119 196))) + +(test-equal "string->uuid" + '(16 "4dab5feb-d176-45de-b287-9b0a6e4c01cb") + (let ((uuid (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))) + (list (bytevector-length uuid) (uuid->string uuid)))) + +(test-assert "uuid" + (let ((str "4dab5feb-d176-45de-b287-9b0a6e4c01cb")) + (bytevector=? (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb") + (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 87f17def12..0de6f278e4 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2014 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2012, 2014, 2015 Ludovic Courtès <ludo@gnu.org> # # This file is part of GNU Guix. # @@ -54,11 +54,12 @@ EOF rm -f "$XDG_CACHE_HOME/guix/substitute/$hash_part" # Make sure we see the substitute. -guile -c ' +guile -c " (use-modules (guix)) (define store (open-connection)) - (set-build-options store #:use-substitutes? #t) - (exit (has-substitutes? store "'"$out"'"))' + (set-build-options store #:use-substitutes? #t + #:substitute-urls (list \"$GUIX_BINARY_SUBSTITUTE_URL\")) + (exit (has-substitutes? store \"$out\"))" # Now, run guix-daemon --no-substitutes. socket="$NIX_STATE_DIR/alternate-socket" @@ -72,6 +73,7 @@ guile -c " (define store (open-connection \"$socket\")) ;; This setting MUST NOT override the daemon's --no-substitutes. - (set-build-options store #:use-substitutes? #t) + (set-build-options store #:use-substitutes? #t + #:substitute-urls (list \"$GUIX_BINARY_SUBSTITUTE_URL\")) (exit (not (has-substitutes? store \"$out\")))" diff --git a/tests/store.scm b/tests/store.scm index faa924fce9..96b64781dd 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -25,6 +25,7 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix serialization) + #:use-module (guix build utils) #:use-module (guix gexp) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) @@ -371,13 +372,13 @@ (with-derivation-narinfo d ;; Remove entry from the local cache. (false-if-exception - (delete-file (string-append (getenv "XDG_CACHE_HOME") - "/guix/substitute/" - (store-path-hash-part o)))) + (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME") + "/guix/substitute"))) ;; Make sure 'guix substitute' correctly communicates the above ;; data. - (set-build-options s #:use-substitutes? #t) + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (equal? (list o) (substitutable-paths s (list o))) (match (pk 'spi (substitutable-path-info s (list o))) @@ -387,6 +388,34 @@ (null? (substitutable-references s)) (equal? (substitutable-nar-size s) 1234))))))))) +(test-assert "substitute query, alternating URLs" + (let* ((d (with-store s + (package-derivation s %bootstrap-guile (%current-system)))) + (o (derivation->output-path d))) + (with-derivation-narinfo d + ;; Remove entry from the local cache. + (false-if-exception + (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME") + "/guix/substitute"))) + + ;; Note: We reconnect to the daemon to force a new instance of 'guix + ;; substitute' to be used; otherwise the #:substitute-urls of + ;; 'set-build-options' would have no effect. + + (and (with-store s ;the right substitute URL + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + (has-substitutes? s o)) + (with-store s ;the wrong one + (set-build-options s #:use-substitutes? #t + #:substitute-urls (list + "http://does-not-exist")) + (not (has-substitutes? s o))) + (with-store s ;the right one again + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + (has-substitutes? s o)))))) + (test-assert "substitute" (with-store s (let* ((c (random-text)) ; contents of the output @@ -400,7 +429,8 @@ (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) (with-derivation-substitute d c - (set-build-options s #:use-substitutes? #t) + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (build-derivations s (list d)) (equal? c (call-with-input-file o get-string-all))))))) @@ -418,7 +448,8 @@ (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) (with-derivation-substitute d c - (set-build-options s #:use-substitutes? #t) + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (build-things s (list o)) ;give the output path (valid-path? s o) @@ -442,7 +473,8 @@ ;; Make sure we use 'guix substitute'. (set-build-options s #:use-substitutes? #t - #:fallback? #f) + #:fallback? #f + #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (guard (c ((nix-protocol-error? c) ;; XXX: the daemon writes "hash mismatch in downloaded @@ -467,13 +499,16 @@ ;; Create fake substituter data, to be read by 'guix substitute'. (with-derivation-narinfo d ;; Make sure we use 'guix substitute'. - (set-build-options s #:use-substitutes? #t) + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (guard (c ((nix-protocol-error? c) ;; The substituter failed as expected. Now make ;; sure that #:fallback? #t works correctly. (set-build-options s #:use-substitutes? #t + #:substitute-urls + (%test-substitute-urls) #:fallback? #t) (and (build-derivations s (list d)) (equal? t (call-with-input-file o diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 8598f747f1..6b614a5211 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -80,6 +80,8 @@ (define (user-namespace pid) (string-append "/proc/" (number->string pid) "/ns/user")) +(unless (file-exists? (user-namespace (getpid))) + (test-skip 1)) (test-assert "clone" (match (clone (logior CLONE_NEWUSER SIGCHLD)) (0 (primitive-exit 42)) @@ -91,6 +93,8 @@ ((_ . status) (= 42 (status:exit-val status)))))))) +(unless (file-exists? (user-namespace (getpid))) + (test-skip 1)) (test-assert "setns" (match (clone (logior CLONE_NEWUSER SIGCHLD)) (0 (primitive-exit 0)) @@ -118,6 +122,8 @@ (waitpid fork-pid) result)))))))) +(unless (file-exists? (user-namespace (getpid))) + (test-skip 1)) (test-assert "pivot-root" (match (pipe) ((in . out) |