ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into core-updates

Browse source
This commit is contained in:
Mark H Weaver 2015-07-15 15:10:32 -04:00
commit 35995769b5
36 changed files with 1022 additions and 244 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -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

38
doc/guix.texi
View file

@ -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

29
emacs/guix-emacs.el
View file

@ -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)))

17
emacs/guix-info.el
View file

@ -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)

4
emacs/guix-init.el.in
View file

@ -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)

4
gnu-system.am
View file

@ -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 \

131
gnu/build/file-systems.scm
View file

@ -22,13 +22,16 @@ (define-module (gnu build file-systems)
#: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 @@ (define-module (gnu build file-systems)
;; '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 @@ (define (partition? major minor)
(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 @@ (define (find-partition-by-label label)
(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 @@ (define* (canonicalize-device-spec spec #:optional (title 'any))
\"/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 @@ (define max-trials
(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))))

3
gnu/packages/admin.scm
View file

@ -480,7 +480,8 @@ (define-public libpcap
"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

2
gnu/packages/algebra.scm
View file

@ -383,7 +383,7 @@ (define-public eigen
(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)

5
gnu/packages/boost.scm
View file

@ -33,7 +33,7 @@ (define-module (gnu packages boost)
(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 @@ (define-public boost
".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

12
gnu/packages/ccache.scm
View file

@ -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-module (gnu packages ccache)
(define-public ccache
(package
(name "ccache")
(version "3.1.10")
(version "3.2.2")
(source
(origin
(method url-fetch)
@ -36,16 +36,18 @@ (define-public ccache
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")

72
gnu/packages/dunst.scm Normal file
View file

@ -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)))

33
gnu/packages/freedesktop.scm
View file

@ -91,6 +91,39 @@ (define-public libinput
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

63
gnu/packages/gcc.scm
View file

@ -27,6 +27,10 @@ (define-module (gnu packages gcc)
#: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 @@ (define-public gcc-objc-4.8
(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")

89
gnu/packages/gnome.scm
View file

@ -2090,11 +2090,12 @@ (define-public gnome-terminal
("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 @@ (define-public totem
;; 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+)))

4
gnu/packages/linux.scm
View file

@ -210,7 +210,7 @@ (define (lookup file)
#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 @@ (define-public linux-libre
(uri (linux-libre-urls version))
(sha256
(base32
"12fdrawzjqhlmjvw79iy9419pf7m3k29xcjri57i4ynaf3yfzkk0"))))
"0clgjpcw1xzqa7jpm6k5fafg3wnc28mzyar3xgr4vbm6zb61fl7k"))))
(build-system gnu-build-system)
(native-inputs `(("perl" ,perl)
("bc" ,bc)

9
gnu/packages/music.scm
View file

@ -424,7 +424,14 @@ (define-public setbfree
(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

27
gnu/packages/ntp.scm
View file

@ -24,6 +24,7 @@ (define-module (gnu packages ntp)
#: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-module (gnu packages ntp)
(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 @@ (define-public ntp
"/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

15
gnu/packages/patches/boost-mips-avoid-m32.patch Normal file
View file

@ -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
{

4
gnu/packages/polkit.scm
View file

@ -35,7 +35,7 @@ (define-module (gnu packages polkit)
(define-public polkit
(package
(name "polkit")
(version "0.112")
(version "0.113")
(source (origin
(method url-fetch)
(uri (string-append
@ -43,7 +43,7 @@ (define-public polkit
name "-" version ".tar.gz"))
(sha256
(base32
"1xkary7yirdcjdva950nqyhmsz48qhrdsr78zciahj27p8yg95fn"))
"109w86kfqrgz83g9ivggplmgc77rz8kx8646izvm2jb57h4rbh71"))
(patches (list (search-patch "polkit-drop-test.patch")))))
(build-system gnu-build-system)
(inputs

6
gnu/packages/pumpio.scm
View file

@ -30,15 +30,15 @@ (define-module (gnu packages pumpio)
(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

72
gnu/packages/rc.scm Normal file
View file

@ -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)))

92
gnu/packages/skarnet.scm Normal file
View file

@ -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.")))

10
gnu/packages/ssh.scm
View file

@ -122,16 +122,18 @@ (define-public libssh2
(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)

59
gnu/system/file-systems.scm
View file

@ -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 @@ (define-module (gnu system file-systems)
file-system-create-mount-point?
file-system->spec
string->uuid
uuid
%fuse-control-file-system
%binary-format-file-system
@ -106,6 +112,57 @@ (define (file-system->spec fs)
(($ <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 @@ (define %base-file-systems
;; 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")

2
gnu/system/install.scm
View file

@ -342,7 +342,7 @@ (define installation-os
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

12
guix/scripts/build.scm
View file

@ -117,6 +117,9 @@ (define (show-build-options-help)
--fallback fall back to building when the substituter fails"))
(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 (_ "
@ -141,6 +144,8 @@ (define (set-build-options-from-command-line store opts)
#: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 @@ (define %standard-build-options
(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

2
guix/scripts/lint.scm
View file

@ -34,8 +34,6 @@ (define-module (guix scripts lint)
#: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))

313
guix/scripts/substitute.scm
View file

@ -25,6 +25,7 @@ (define-module (guix scripts substitute)
#: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 @@ (define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f))
(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-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 (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 (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 @@ (define (obsolete? date now ttl)
(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)))
(bytevector->base32-string (sha256 (string->utf8 cache-url)))
"/" (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."
(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 @@ (define cache-file
(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 @@ (define (cache-entry cache-uri narinfo)
(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 @@ (define (narinfo-from-file file url)
#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 @@ (define (handle-narinfo-response request response port)
(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 @@ (define (handle-narinfo-response request response port)
(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 @@ (define (handle-narinfo-response request response port)
(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 @@ (define (lookup-narinfos cache paths)
(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 @@ (define (lookup-narinfos cache paths)
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 @@ (define (lookup-narinfo cache path)
(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 @@ (define (expired? file)
#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 @@ (define last-expiry-date
(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) <>))))
@ -688,6 +697,95 @@ (define (show-help)
(show-bug-report-information))
;;;
;;; 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 @@ (define (find-daemon-option option)
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 @@ (define (guix-substitute . args)
(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 @@ (define (valid? obj)
(opts
(leave (_ "~a: unrecognized options~%") opts))))))
;;; Local Variables:
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; End:

1
guix/store.scm
View file

@ -37,6 +37,7 @@ (define-module (guix store)
#:use-module (ice-9 popen)
#:export (%daemon-socket-file
%gc-roots-directory
%default-substitute-urls
nix-server?
nix-server-major-version

11
guix/tests.scm
View file

@ -36,6 +36,7 @@ (define-module (guix tests)
network-reachable?
shebang-too-long?
mock
%test-substitute-urls
%substitute-directory
with-derivation-narinfo
with-derivation-substitute
@ -49,6 +50,12 @@ (define-module (guix tests)
;;;
;;; 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 @@ (define (open-connection-for-tests)
#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.

9
tests/derivations.scm
View file

@ -612,7 +612,8 @@ (define %coreutils
(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 @@ (define %coreutils
(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 @@ (define %coreutils
(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)

46
tests/file-systems.scm Normal file
View file

@ -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))

12
tests/guix-daemon.sh
View file

@ -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\")))"

51
tests/store.scm
View file

@ -25,6 +25,7 @@ (define-module (test-store)
#: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 @@ (define (same? x y)
(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 @@ (define (same? x y)
(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 @@ (define (same? x y)
(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 @@ (define (same? x y)
(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 @@ (define (same? x y)
;; 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 @@ (define (same? x y)
;; 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

6
tests/syscalls.scm
View file

@ -80,6 +80,8 @@ (define-module (test-syscalls)
(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 @@ (define (user-namespace pid)
((_ . 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 @@ (define (user-namespace pid)
(waitpid fork-pid)
result))))))))
(unless (file-exists? (user-namespace (getpid)))
(test-skip 1))
(test-assert "pivot-root"
(match (pipe)
((in . out)