amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into core-updates

Browse source
This commit is contained in:
Ludovic Courtès 2014-06-06 17:23:14 +02:00
commit 872c69d00e
45 changed files with 1579 additions and 745 deletions
Download patch file Download diff file Expand all files Collapse all files

33
build-aux/hydra/demo-os.scm
View file

@ -24,23 +24,19 @@
(use-modules (gnu) (use-modules (gnu)
(gnu packages zile)
(gnu packages xorg) (gnu packages xorg)
(gnu packages admin) (gnu packages avahi)
(gnu packages guile)
(gnu packages bash)
(gnu packages linux)
(gnu packages less)
(gnu packages tor)
(gnu packages package-management)
(gnu services networking) (gnu services networking)
(gnu services avahi)
(gnu services dbus)
(gnu services xorg)) (gnu services xorg))
(operating-system (operating-system
(host-name "gnu") (host-name "gnu")
(timezone "Europe/Paris") (timezone "Europe/Paris")
(locale "en_US.UTF-8") (locale "en_US.UTF-8")
(bootloader (grub-configuration (bootloader (grub-configuration
(device "/dev/sda"))) (device "/dev/sda")))
(file-systems (file-systems
@ -52,6 +48,7 @@
(type "dummy")) (type "dummy"))
;; %fuse-control-file-system ; needs fuse.ko ;; %fuse-control-file-system ; needs fuse.ko
%binary-format-file-system)) %binary-format-file-system))
(users (list (user-account (users (list (user-account
(name "guest") (name "guest")
(group "wheel") (group "wheel")
@ -67,6 +64,17 @@
(name "users") (name "users")
(id 100) (id 100)
(members '("guest"))))) (members '("guest")))))
(issue "
This is an alpha preview of the GNU system. Welcome.
This image features the GNU Guix package manager, which was used to
build it (http://www.gnu.org/software/guix/). The init system is
GNU dmd (http://www.gnu.org/software/dmd/).
You can log in as 'guest' or 'root' with no password.
")
(services (cons* (slim-service #:auto-login? #t (services (cons* (slim-service #:auto-login? #t
#:default-user "guest") #:default-user "guest")
@ -75,11 +83,12 @@
#:name-servers '("10.0.2.3") #:name-servers '("10.0.2.3")
#:gateway "10.0.2.2") #:gateway "10.0.2.2")
(avahi-service)
(dbus-service (list avahi))
%base-services)) %base-services))
(pam-services (pam-services
;; Explicitly allow for empty passwords. ;; Explicitly allow for empty passwords.
(base-pam-services #:allow-empty-passwords? #t)) (base-pam-services #:allow-empty-passwords? #t))
(packages (list bash coreutils findutils grep sed
procps psmisc less (packages (cons* xterm avahi %base-packages)))
guile-2.0 dmd guix util-linux inetutils
xterm zile)))

47
build-aux/hydra/gnu-system.scm
View file

@ -55,6 +55,7 @@
(gnu packages make-bootstrap) (gnu packages make-bootstrap)
(gnu system) (gnu system)
(gnu system vm) (gnu system vm)
(gnu system install)
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-26) (srfi srfi-26)
(ice-9 match)) (ice-9 match))
@ -114,6 +115,12 @@ SYSTEM."
'("mips64el-linux-gnu" '("mips64el-linux-gnu"
"mips64el-linux-gnuabi64")) "mips64el-linux-gnuabi64"))
(define (demo-os)
"Return the \"demo\" 'operating-system' structure."
(let* ((dir (dirname (assoc-ref (current-source-location) 'filename)))
(file (string-append dir "/demo-os.scm")))
(read-operating-system file)))
(define (qemu-jobs store system) (define (qemu-jobs store system)
"Return a list of jobs that build QEMU images for SYSTEM." "Return a list of jobs that build QEMU images for SYSTEM."
(define (->alist drv) (define (->alist drv)
@ -130,24 +137,28 @@ system.")
(string->symbol system)))) (string->symbol system))))
`(,name . ,(cut ->alist drv)))) `(,name . ,(cut ->alist drv))))
(if (string=? system "x86_64-linux") (define MiB
(let* ((dir (dirname (assoc-ref (current-source-location) 'filename))) (expt 2 20))
(file (string-append dir "/demo-os.scm"))
(os (read-operating-system file)) (if (member system '("x86_64-linux" "i686-linux"))
(size (* 1400 (expt 2 20)))) ; 1.4GiB (list (->job 'qemu-image
(if (operating-system? os) (run-with-store store
(list (->job 'qemu-image (system-qemu-image (demo-os)
(run-with-store store #:disk-image-size
(system-qemu-image os (* 1400 MiB)))) ; 1.4 GiB
#:disk-image-size size)))) (->job 'usb-image
'())) (run-with-store store
(system-disk-image installation-os
#:disk-image-size
(* 630 MiB)))))
'())) '()))
(define (hydra-jobs store arguments) (define (hydra-jobs store arguments)
"Return Hydra jobs." "Return Hydra jobs."
(define systems (define systems
;; Systems we want to build for. ;; Systems we want to build for.
'("x86_64-linux" "i686-linux")) '("x86_64-linux" "i686-linux"
"mips64el-linux"))
(define subset (define subset
(match (assoc-ref arguments 'subset) (match (assoc-ref arguments 'subset)
@ -165,12 +176,22 @@ system.")
(and (string-prefix? "i686-" system) (and (string-prefix? "i686-" system)
(string-suffix? "64" target))) (string-suffix? "64" target)))
(define (same? target)
;; Return true if SYSTEM and TARGET are the same thing. This is so we
;; don't try to cross-compile to 'mips64el-linux-gnu' from
;; 'mips64el-linux'.
(string-contains target system))
(define (either proc1 proc2)
(lambda (x)
(or (proc1 x) (proc2 x))))
(append-map (lambda (target) (append-map (lambda (target)
(map (lambda (package) (map (lambda (package)
(package-cross-job store (job-name package) (package-cross-job store (job-name package)
package target system)) package target system))
%packages-to-cross-build)) %packages-to-cross-build))
(remove from-32-to-64? %cross-targets))) (remove (either from-32-to-64? same?) %cross-targets)))
;; Return one job for each package, except bootstrap packages. ;; Return one job for each package, except bootstrap packages.
(let ((base-packages (delete-duplicates (let ((base-packages (delete-duplicates

5
build-aux/list-packages.scm
View file

@ -4,7 +4,7 @@ exec guile -l "$0" \
(cdr (command-line)))' (cdr (command-line)))'
!# !#
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Alex Sassmannshausen <alex.sassmannshausen@gmail.com> ;;; Copyright © 2013 Alex Sassmannshausen <alex.sassmannshausen@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -148,7 +148,8 @@ decreasing, is 1."
`(div "status: " `(div "status: "
,(url "x86_64-linux") " " ,(url "x86_64-linux") " "
,(url "i686-linux"))) ,(url "i686-linux") " "
,(url "mips64el-linux")))
(define (package-logo name) (define (package-logo name)
(and=> (lookup-gnu-package name) (and=> (lookup-gnu-package name)

45
doc/guix.texi
View file

@ -1737,7 +1737,7 @@ a derivation is the @code{derivation} procedure:
@var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @
[#:recursive? #f] [#:inputs '()] [#:env-vars '()] @ [#:recursive? #f] [#:inputs '()] [#:env-vars '()] @
[#:system (%current-system)] [#:references-graphs #f] @ [#:system (%current-system)] [#:references-graphs #f] @
[#:local-build? #f] [#:allowed-references #f] [#:local-build? #f]
Build a derivation with the given arguments, and return the resulting Build a derivation with the given arguments, and return the resulting
@code{<derivation>} object. @code{<derivation>} object.
@ -1753,6 +1753,9 @@ name/store path pairs. In that case, the reference graph of each store
path is exported in the build environment in the corresponding file, in path is exported in the build environment in the corresponding file, in
a simple text format. a simple text format.
When @var{allowed-references} is true, it must be a list of store items
or outputs that the derivation's output may refer to.
When @var{local-build?} is true, declare that the derivation is not a When @var{local-build?} is true, declare that the derivation is not a
good candidate for offloading and should rather be built locally good candidate for offloading and should rather be built locally
(@pxref{Daemon Offload Setup}). This is the case for small derivations (@pxref{Daemon Offload Setup}). This is the case for small derivations
@ -1795,7 +1798,8 @@ is now deprecated in favor of the much nicer @code{gexp->derivation}.
[#:system (%current-system)] [#:inputs '()] @ [#:system (%current-system)] [#:inputs '()] @
[#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @
[#:recursive? #f] [#:env-vars '()] [#:modules '()] @ [#:recursive? #f] [#:env-vars '()] [#:modules '()] @
[#:references-graphs #f] [#:local-build? #f] [#:guile-for-build #f] [#:references-graphs #f] [#:allowed-references #f] @
[#:local-build? #f] [#:guile-for-build #f]
Return a derivation that executes Scheme expression @var{exp} as a Return a derivation that executes Scheme expression @var{exp} as a
builder for derivation @var{name}. @var{inputs} must be a list of builder for derivation @var{name}. @var{inputs} must be a list of
@code{(name drv-path sub-drv)} tuples; when @var{sub-drv} is omitted, @code{(name drv-path sub-drv)} tuples; when @var{sub-drv} is omitted,
@ -1817,8 +1821,8 @@ terminates by passing the result of @var{exp} to @code{exit}; thus, when
@var{guile-for-build} is omitted or is @code{#f}, the value of the @var{guile-for-build} is omitted or is @code{#f}, the value of the
@code{%guile-for-build} fluid is used instead. @code{%guile-for-build} fluid is used instead.
See the @code{derivation} procedure for the meaning of @var{references-graphs} See the @code{derivation} procedure for the meaning of
and @var{local-build?}. @var{references-graphs}, @var{allowed-references}, and @var{local-build?}.
@end deffn @end deffn
@noindent @noindent
@ -3113,14 +3117,8 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this:
@findex operating-system @findex operating-system
@lisp @lisp
(use-modules (gnu) ; for 'user-account', '%base-services', etc. (use-modules (gnu) ; for 'user-account', '%base-services', etc.
(gnu services ssh) ; for 'lsh-service' (gnu packages emacs) ; for 'emacs'
(gnu packages base) ; Coreutils, grep, etc. (gnu services ssh)) ; for 'lsh-service'
(gnu packages bash) ; Bash
(gnu packages admin) ; dmd, Inetutils
(gnu packages zile) ; Zile
(gnu packages less) ; less
(gnu packages guile) ; Guile
(gnu packages linux)) ; procps, psmisc
(define komputilo (define komputilo
(operating-system (operating-system
@ -3130,7 +3128,7 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this:
(bootloader (grub-configuration (bootloader (grub-configuration
(device "/dev/sda"))) (device "/dev/sda")))
(file-systems (list (file-system (file-systems (list (file-system
(device "/dev/disk/by-label/root") (device "/dev/sda1") ; or partition label
(mount-point "/") (mount-point "/")
(type "ext3")))) (type "ext3"))))
(users (list (user-account (users (list (user-account
@ -3139,22 +3137,21 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this:
(uid 1000) (gid 100) (uid 1000) (gid 100)
(comment "Bob's sister") (comment "Bob's sister")
(home-directory "/home/alice")))) (home-directory "/home/alice"))))
(packages (list coreutils bash guile-2.0 (packages (cons emacs %base-packages))
guix dmd
inetutils
findutils grep sed
procps psmisc
zile less))
(services (cons (lsh-service #:port 2222 #:allow-root-login? #t) (services (cons (lsh-service #:port 2222 #:allow-root-login? #t)
%base-services)))) %base-services))))
@end lisp @end lisp
This example should be self-describing. The @code{packages} field lists This example should be self-describing. The @code{packages} field lists
packages provided by the various @code{(gnu packages ...)} modules above packages that will be globally visible on the system, for all user
(@pxref{Package Modules}). These are the packages that will be globally accounts---i.e., in every user's @code{PATH} environment variable---in
visible on the system, for all user accounts---i.e., in every user's addition to the per-user profiles (@pxref{Invoking guix package}). The
@code{PATH} environment variable---in addition to the per-user profiles @var{%base-packages} variables provides all the tools one would expect
(@pxref{Invoking guix package}). for basic user and administrator tasks---including the GNU Core
Utilities, the GNU Networking Utilities, the GNU Zile lightweight text
editor, @command{find}, @command{grep}, etc. The example above adds
Emacs to those, taken from the @code{(gnu packages emacs)} module
(@pxref{Package Modules}).
@vindex %base-services @vindex %base-services
The @code{services} field lists @dfn{system services} to be made The @code{services} field lists @dfn{system services} to be made

12
gnu-system.am
View file

@ -62,15 +62,14 @@ GNU_SYSTEM_MODULES = \
gnu/packages/cyrus-sasl.scm \ gnu/packages/cyrus-sasl.scm \
gnu/packages/dc.scm \ gnu/packages/dc.scm \
gnu/packages/dejagnu.scm \ gnu/packages/dejagnu.scm \
gnu/packages/ddrescue.scm \
gnu/packages/dictionaries.scm \ gnu/packages/dictionaries.scm \
gnu/packages/disk.scm \
gnu/packages/docbook.scm \ gnu/packages/docbook.scm \
gnu/packages/doxygen.scm \ gnu/packages/doxygen.scm \
gnu/packages/dwm.scm \ gnu/packages/dwm.scm \
gnu/packages/ed.scm \ gnu/packages/ed.scm \
gnu/packages/elf.scm \ gnu/packages/elf.scm \
gnu/packages/emacs.scm \ gnu/packages/emacs.scm \
gnu/packages/fdisk.scm \
gnu/packages/file.scm \ gnu/packages/file.scm \
gnu/packages/flex.scm \ gnu/packages/flex.scm \
gnu/packages/fltk.scm \ gnu/packages/fltk.scm \
@ -177,7 +176,6 @@ GNU_SYSTEM_MODULES = \
gnu/packages/openssl.scm \ gnu/packages/openssl.scm \
gnu/packages/package-management.scm \ gnu/packages/package-management.scm \
gnu/packages/parallel.scm \ gnu/packages/parallel.scm \
gnu/packages/parted.scm \
gnu/packages/patchutils.scm \ gnu/packages/patchutils.scm \
gnu/packages/pciutils.scm \ gnu/packages/pciutils.scm \
gnu/packages/pcre.scm \ gnu/packages/pcre.scm \
@ -256,6 +254,7 @@ GNU_SYSTEM_MODULES = \
gnu/system.scm \ gnu/system.scm \
gnu/system/file-systems.scm \ gnu/system/file-systems.scm \
gnu/system/grub.scm \ gnu/system/grub.scm \
gnu/system/install.scm \
gnu/system/linux.scm \ gnu/system/linux.scm \
gnu/system/linux-initrd.scm \ gnu/system/linux-initrd.scm \
gnu/system/shadow.scm \ gnu/system/shadow.scm \
@ -279,6 +278,8 @@ dist_patch_DATA = \
gnu/packages/patches/coreutils-dummy-man.patch \ gnu/packages/patches/coreutils-dummy-man.patch \
gnu/packages/patches/coreutils-skip-nohup.patch \ gnu/packages/patches/coreutils-skip-nohup.patch \
gnu/packages/patches/cpio-gets-undeclared.patch \ gnu/packages/patches/cpio-gets-undeclared.patch \
gnu/packages/patches/cssc-gets-undeclared.patch \
gnu/packages/patches/cssc-missing-include.patch \
gnu/packages/patches/curl-fix-test172.patch \ gnu/packages/patches/curl-fix-test172.patch \
gnu/packages/patches/dbus-localstatedir.patch \ gnu/packages/patches/dbus-localstatedir.patch \
gnu/packages/patches/diffutils-gets-undeclared.patch \ gnu/packages/patches/diffutils-gets-undeclared.patch \
@ -311,7 +312,6 @@ dist_patch_DATA = \
gnu/packages/patches/guile-relocatable.patch \ gnu/packages/patches/guile-relocatable.patch \
gnu/packages/patches/guix-test-networking.patch \ gnu/packages/patches/guix-test-networking.patch \
gnu/packages/patches/gtkglext-disable-disable-deprecated.patch \ gnu/packages/patches/gtkglext-disable-disable-deprecated.patch \
gnu/packages/patches/gtkglext-remove-pangox-dependency.patch \
gnu/packages/patches/hop-bigloo-4.0b.patch \ gnu/packages/patches/hop-bigloo-4.0b.patch \
gnu/packages/patches/inkscape-stray-comma.patch \ gnu/packages/patches/inkscape-stray-comma.patch \
gnu/packages/patches/libevent-dns-tests.patch \ gnu/packages/patches/libevent-dns-tests.patch \
@ -331,8 +331,7 @@ dist_patch_DATA = \
gnu/packages/patches/mhash-keygen-test-segfault.patch \ gnu/packages/patches/mhash-keygen-test-segfault.patch \
gnu/packages/patches/mit-krb5-init-fix.patch \ gnu/packages/patches/mit-krb5-init-fix.patch \
gnu/packages/patches/mpc123-initialize-ao.patch \ gnu/packages/patches/mpc123-initialize-ao.patch \
gnu/packages/patches/openssl-CVE-2010-5298.patch \ gnu/packages/patches/module-init-tools-moduledir.patch \
gnu/packages/patches/openssl-extension-checking-fixes.patch \
gnu/packages/patches/patchelf-page-size.patch \ gnu/packages/patches/patchelf-page-size.patch \
gnu/packages/patches/patchutils-xfail-gendiff-tests.patch \ gnu/packages/patches/patchutils-xfail-gendiff-tests.patch \
gnu/packages/patches/perl-no-sys-dirs.patch \ gnu/packages/patches/perl-no-sys-dirs.patch \
@ -359,6 +358,7 @@ dist_patch_DATA = \
gnu/packages/patches/superlu-dist-scotchmetis.patch \ gnu/packages/patches/superlu-dist-scotchmetis.patch \
gnu/packages/patches/tcsh-fix-autotest.patch \ gnu/packages/patches/tcsh-fix-autotest.patch \
gnu/packages/patches/teckit-cstdio.patch \ gnu/packages/patches/teckit-cstdio.patch \
gnu/packages/patches/util-linux-perl.patch \
gnu/packages/patches/valgrind-glibc.patch \ gnu/packages/patches/valgrind-glibc.patch \
gnu/packages/patches/vpnc-script.patch \ gnu/packages/patches/vpnc-script.patch \
gnu/packages/patches/w3m-fix-compile.patch \ gnu/packages/patches/w3m-fix-compile.patch \

38
gnu/packages/admin.scm
View file

@ -722,3 +722,41 @@ This package provides the 'wpa_supplicant' daemon and the 'wpa_cli' command.")
;; In practice, this is linked against Readline, which makes it GPLv3+. ;; In practice, this is linked against Readline, which makes it GPLv3+.
(license bsd-3))) (license bsd-3)))
(define-public wakelan
(package
(name "wakelan")
(version "1.1")
(source (origin
(method url-fetch)
(uri (string-append
"ftp://ftp.gwdg.de/pub/linux/metalab/system/network/misc/wakelan-"
version ".tar.gz"))
(sha256
(base32
"0vydqpf44146ir6k87gmqaq6xy66xhc1gkr3nsd7jj3nhy7ypx9x"))))
(build-system gnu-build-system)
(arguments
'(#:phases (alist-replace
'configure
(lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out")))
(mkdir-p (string-append out "/bin"))
(mkdir-p (string-append out "/share/man/man1"))
;; It's an old configure script that doesn't understand
;; the extra options we pass.
(setenv "CONFIG_SHELL" (which "bash"))
(zero?
(system* "./configure"
(string-append "--prefix=" out)
(string-append "--mandir=" out
"/share/man")))))
%standard-phases)
#:tests? #f))
(home-page "http://kernel.org") ; really, no home page
(synopsis "Send a wake-on-LAN packet")
(description
"WakeLan broadcasts a properly formatted UDP packet across the local area
network, which causes enabled computers to power on.")
(license gpl2+)))

214
gnu/packages/backup.scm
View file

@ -18,13 +18,25 @@
(define-module (gnu packages backup) (define-module (gnu packages backup)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix licenses) #:use-module ((guix licenses)
#:renamer (symbol-prefix-proc 'license:))
#:use-module (guix download) #:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix build-system python) #:use-module (guix build-system python)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages python) #:use-module (gnu packages base)
#:use-module (gnu packages compression)
#:use-module (gnu packages dejagnu)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnupg) #:use-module (gnu packages gnupg)
#:use-module (gnu packages mcrypt)
#:use-module (gnu packages nettle)
#:use-module (gnu packages pcre)
#:use-module (gnu packages python)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages rsync) #:use-module (gnu packages rsync)
#:use-module (gnu packages ssh)
#:use-module (gnu packages xml)
#:use-module (srfi srfi-1)) #:use-module (srfi srfi-1))
(define-public duplicity (define-public duplicity
@ -68,4 +80,200 @@ librsync, the incremental archives are space efficient and only record the
parts of files that have changed since the last backup. Because duplicity parts of files that have changed since the last backup. Because duplicity
uses GnuPG to encrypt and/or sign these archives, they will be safe from uses GnuPG to encrypt and/or sign these archives, they will be safe from
spying and/or modification by the server.") spying and/or modification by the server.")
(license gpl2+))) (license license:gpl2+)))
(define-public hdup
(package
(name "hdup")
(version "2.0.14")
(source
(origin
(method url-fetch)
;; Source tarballs are not versioned
(uri "http://archive.miek.nl/projects/hdup2/hdup.tar.bz2")
(sha256
(base32
"02bnczg01cyhajmm4rhbnc0ja0dd9ikv9fwv28asxh1rlx9yr0b7"))))
(build-system gnu-build-system)
(native-inputs `(("pkg-config" ,pkg-config)))
(inputs
`(("glib" ,glib)
("tar" ,tar)
("lzop" ,lzop)
("mcrypt" ,mcrypt)
("openssh" ,openssh)
("gnupg" ,gnupg-1)))
(arguments
`(#:configure-flags
`(,(string-append "--sbindir=" (assoc-ref %outputs "out") "/bin"))
#:tests? #f))
(home-page "http://archive.miek.nl/projects/hdup/index.html")
(synopsis "Simple incremental backup tool")
(description
"Hdup2 is a backup utilty, its aim is to make backup really simple. The
backup scheduling is done by means of a cron job. It supports an
include/exclude mechanism, remote backups, encrypted backups and split
backups (called chunks) to allow easy burning to CD/DVD.")
(license license:gpl2)))
(define-public libarchive
(package
(name "libarchive")
(version "3.1.2")
(source
(origin
(method url-fetch)
(uri (string-append "http://libarchive.org/downloads/libarchive-"
version ".tar.gz"))
(sha256
(base32
"0pixqnrcf35dnqgv0lp7qlcw7k13620qkhgxr288v7p4iz6ym1zb"))))
(build-system gnu-build-system)
(inputs
`(("zlib" ,zlib)
("nettle" ,nettle)
("lzo" ,lzo)
("bzip2" ,bzip2)
("libxml2" ,libxml2)
("xz" ,xz)))
(arguments
`(#:phases
(alist-cons-before
'build 'patch-pwd
(lambda _
(substitute* "Makefile"
(("/bin/pwd") (which "pwd"))))
(alist-replace
'check
(lambda _
;; XXX: The test_owner_parse, test_read_disk, and
;; test_write_disk_lookup tests expect user 'root' to exist, but
;; the chroot's /etc/passwd doesn't have it. Turn off those tests.
;;
;; The tests allow one to disable tests matching a globbing pattern.
(and (zero? (system* "make"
"libarchive_test" "bsdcpio_test" "bsdtar_test"))
;; XXX: This glob disables too much.
(zero? (system* "./libarchive_test" "^test_*_disk*"))
(zero? (system* "./bsdcpio_test" "^test_owner_parse"))
(zero? (system* "./bsdtar_test"))))
%standard-phases))))
(home-page "http://libarchive.org/")
(synopsis "Multi-format archive and compression library")
(description
"Libarchive provides a flexible interface for reading and writing
archives in various formats such as tar and cpio. Libarchive also supports
reading and writing archives compressed using various compression filters such
as gzip and bzip2. The library is inherently stream-oriented; readers
serially iterate through the archive, writers serially add things to the
archive. In particular, note that there is currently no built-in support for
random access nor for in-place modification.")
(license license:bsd-2)))
(define-public rdup
(package
(name "rdup")
(version "1.1.14")
(source
(origin
(method url-fetch)
(uri (string-append "http://archive.miek.nl/projects/rdup/rdup-"
version ".tar.bz2"))
(sha256
(base32
"0aklwd9v7ix0m4ayl762sil685f42cwljzx3jz5skrnjaq32npmj"))))
(build-system gnu-build-system)
(native-inputs
`(("pkg-config" ,pkg-config)
("dejagnu" ,dejagnu)))
(inputs
`(("glib" ,glib)
("pcre" ,pcre)
("libarchive" ,libarchive)
("nettle" ,nettle)))
(arguments
`(#:parallel-build? #f ;race conditions
#:phases (alist-cons-before
'build 'remove-Werror
;; rdup uses a deprecated function from libarchive
(lambda _
(substitute* "GNUmakefile"
(("^(CFLAGS=.*)-Werror" _ front) front)))
%standard-phases)))
(home-page "http://archive.miek.nl/projects/rdup/index.html")
(synopsis "Provide a list of files to backup")
(description
"Rdup is a utility inspired by rsync and the plan9 way of doing backups.
Rdup itself does not backup anything, it only print a list of absolute
filenames to standard output. Auxiliary scripts are needed that act on this
list and implement the backup strategy.")
(license license:gpl3+)))
(define-public btar
(package
(name "btar")
(version "1.1.1")
(source
(origin
(method url-fetch)
(uri (string-append "http://vicerveza.homeunix.net/~viric/soft/btar/"
"btar-" version ".tar.gz"))
(sha256
(base32
"0miklk4bqblpyzh1bni4x6lqn88fa8fjn15x1k1n8bxkx60nlymd"))))
(build-system gnu-build-system)
(inputs
`(("librsync" ,librsync)))
(arguments
`(#:make-flags `(,(string-append "PREFIX=" (assoc-ref %outputs "out"))
"CC=gcc")
#:tests? #f ;test input not distributed
#:phases
(alist-delete
'configure ;no configure phase
%standard-phases)))
(home-page "http://viric.name/cgi-bin/btar/doc/trunk/doc/home.wiki")
(synopsis "Tar-compatible archiver")
(description
"Btar is a tar-compatible archiver which allows arbitrary compression and
ciphering, redundancy, differential backup, indexed extraction, multicore
compression, input and output serialisation, and tolerance to partial archive
errors.")
(license license:gpl3+)))
(define-public rdiff-backup
(package
(name "rdiff-backup")
(version "1.2.8")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://savannah/rdiff-backup/rdiff-backup-"
version ".tar.gz"))
(sha256
(base32
"1nwmmh816f96h0ff1jxk95ad38ilbhbdl5dgibx1d4cl81dsi48d"))))
(build-system python-build-system)
(native-inputs
`(("python2-setuptools" ,python2-setuptools)))
(inputs
`(("python" ,python-2)
("librsync" ,librsync)))
(arguments
`(#:python ,python-2
#:tests? #f))
(home-page "http://www.nongnu.org/rdiff-backup/")
(synopsis "Local/remote mirroring+incremental backup")
(description
"Rdiff-backup backs up one directory to another, possibly over a network.
The target directory ends up a copy of the source directory, but extra reverse
diffs are stored in a special subdirectory of that target directory, so you
can still recover files lost some time ago. The idea is to combine the best
features of a mirror and an incremental backup. Rdiff-backup also preserves
subdirectories, hard links, dev files, permissions, uid/gid ownership,
modification times, extended attributes, acls, and resource forks. Also,
rdiff-backup can operate in a bandwidth efficient manner over a pipe, like
rsync. Thus you can use rdiff-backup and ssh to securely back a hard drive up
to a remote location, and only the differences will be transmitted. Finally,
rdiff-backup is easy to use and settings have sensical defaults.")
(license license:gpl2+)))

1
gnu/packages/base.scm
View file

@ -976,6 +976,7 @@ exec ~a/bin/~a-~a -B~a/lib -Wl,-dynamic-linker -Wl,~a/~a \"$@\"~%"
;; The final GCC. ;; The final GCC.
(package (inherit gcc-boot0) (package (inherit gcc-boot0)
(name "gcc") (name "gcc")
(location (source-properties->location (current-source-location)))
(arguments (arguments
`(#:guile ,%bootstrap-guile `(#:guile ,%bootstrap-guile
#:implicit-inputs? #f #:implicit-inputs? #f

10
gnu/packages/bdb.scm
View file

@ -34,13 +34,21 @@
(sha256 (base32 (sha256 (base32
"1f2g2612lf8djbwbwhxsvmffmf9d7693kh2l20195pqp0f9jmnfx")))) "1f2g2612lf8djbwbwhxsvmffmf9d7693kh2l20195pqp0f9jmnfx"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(outputs '("out" ; programs, libraries, headers
"doc")) ; 94 MiB of HTML docs
(arguments (arguments
'(#:tests? #f ; no check target available '(#:tests? #f ; no check target available
#:phases #:phases
(alist-replace (alist-replace
'configure 'configure
(lambda* (#:key outputs #:allow-other-keys) (lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))) (let ((out (assoc-ref outputs "out"))
(doc (assoc-ref outputs "doc")))
;; '--docdir' is not honored, so we need to patch.
(substitute* "dist/Makefile.in"
(("docdir[[:blank:]]*=.*")
(string-append "docdir = " doc "/share/doc/bdb")))
(zero? (zero?
(system* "./dist/configure" (system* "./dist/configure"
(string-append "--prefix=" out) (string-append "--prefix=" out)

1
gnu/packages/compression.scm
View file

@ -315,3 +315,4 @@ archives that can be readily emailed. A shell archive is a file that can be
processed by a Bourne-type shell to unpack the original collection of files. processed by a Bourne-type shell to unpack the original collection of files.
This package is mostly for compatibility and historical interest.") This package is mostly for compatibility and historical interest.")
(license license:gpl3+))) (license license:gpl3+)))

47
gnu/packages/ddrescue.scm
View file

@ -1,47 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages ddrescue)
#:use-module (guix licenses)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module ((gnu packages compression) #:select (lzip)))
(define-public ddrescue
(package
(name "ddrescue")
(version "1.17")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://gnu/ddrescue/ddrescue-"
version ".tar.lz"))
(sha256
(base32
"0bvmsbzli2j4czwkabzs978n1y6vx31axh02kpgcf7033cc6rydy"))))
(build-system gnu-build-system)
(home-page "http://www.gnu.org/software/ddrescue/ddrescue.html")
(synopsis "Data recovery utility")
(native-inputs `(("lzip" ,lzip)))
(description
"GNU ddrescue is a fully automated data recovery tool. It copies data
from one file to another, working to rescue data in case of read errors. The
program also includes a tool for manipulating its log files, which are used
to recover data more efficiently by only reading the necessary blocks.")
(license gpl3+)))

58
gnu/packages/parted.scm → gnu/packages/disk.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -16,7 +16,7 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages parted) (define-module (gnu packages disk)
#:use-module (guix licenses) #:use-module (guix licenses)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix download) #:use-module (guix download)
@ -24,7 +24,10 @@
#:use-module (gnu packages check) #:use-module (gnu packages check)
#:use-module (gnu packages gettext) #:use-module (gnu packages gettext)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
#:use-module (gnu packages readline)) #:use-module (gnu packages readline)
#:use-module (gnu packages guile)
#:use-module ((gnu packages compression)
#:select (lzip)))
(define-public parted (define-public parted
(package (package
@ -67,3 +70,52 @@
"GNU Parted is a package for creating and manipulating disk partition "GNU Parted is a package for creating and manipulating disk partition
tables. It includes a library and command-line utility.") tables. It includes a library and command-line utility.")
(license gpl3+))) (license gpl3+)))
(define-public fdisk
(package
(name "fdisk")
(version "2.0.0a")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://gnu/fdisk/gnufdisk-"
version ".tar.gz"))
(sha256
(base32
"04nd7civ561x2lwcmxhsqbprml3178jfc58fy1v7hzqg5k4nbhy3"))))
(build-system gnu-build-system)
(inputs
`(("gettext" ,gnu-gettext)
("guile" ,guile-1.8)
("util-linux" ,util-linux)
("parted" ,parted)))
(home-page "https://www.gnu.org/software/fdisk/")
(synopsis "Low-level disk partitioning and formatting")
(description
"GNU fdisk provides a GNU version of the common disk partitioning tool
fdisk. fdisk is used for the creation and manipulation of disk partition
tables, and it understands a variety of different formats.")
(license gpl3+)))
(define-public ddrescue
(package
(name "ddrescue")
(version "1.17")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://gnu/ddrescue/ddrescue-"
version ".tar.lz"))
(sha256
(base32
"0bvmsbzli2j4czwkabzs978n1y6vx31axh02kpgcf7033cc6rydy"))))
(build-system gnu-build-system)
(home-page "http://www.gnu.org/software/ddrescue/ddrescue.html")
(synopsis "Data recovery utility")
(native-inputs `(("lzip" ,lzip)))
(description
"GNU ddrescue is a fully automated data recovery tool. It copies data
from one file to another, working to rescue data in case of read errors. The
program also includes a tool for manipulating its log files, which are used
to recover data more efficiently by only reading the necessary blocks.")
(license gpl3+)))

9
gnu/packages/elf.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -47,8 +47,11 @@
(native-inputs `(("m4" ,m4))) (native-inputs `(("m4" ,m4)))
(inputs `(("zlib" ,zlib))) (inputs `(("zlib" ,zlib)))
(home-page "https://fedorahosted.org/elfutils/") (home-page "https://fedorahosted.org/elfutils/")
(synopsis #f) (synopsis "Linker and ELF manipulation tools")
(description #f) (description
"This package provides command-line tools to manipulate binaries in the
Executable and Linkable Format (ELF). This includes ld, ar, objdump,
addr2line, and more.")
;; Libraries are dual-licensed LGPLv3.0+ | GPLv2, and programs are GPLv3+. ;; Libraries are dual-licensed LGPLv3.0+ | GPLv2, and programs are GPLv3+.
(license lgpl3+))) (license lgpl3+)))

53
gnu/packages/fdisk.scm
View file

@ -1,53 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages fdisk)
#:use-module ((guix licenses) #:select (gpl3+))
#:use-module (gnu packages gettext)
#:use-module (gnu packages guile)
#:use-module (gnu packages linux)
#:use-module (gnu packages parted)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu))
(define-public fdisk
(package
(name "fdisk")
(version "2.0.0a")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://gnu/fdisk/gnufdisk-"
version ".tar.gz"))
(sha256
(base32
"04nd7civ561x2lwcmxhsqbprml3178jfc58fy1v7hzqg5k4nbhy3"))))
(build-system gnu-build-system)
(inputs
`(("gettext" ,gnu-gettext)
("guile" ,guile-1.8)
("util-linux" ,util-linux)
("parted" ,parted)))
(home-page "https://www.gnu.org/software/fdisk/")
(synopsis "Low-level disk partitioning and formatting")
(description
"GNU fdisk provides a GNU version of the common disk partitioning tool
fdisk. fdisk is used for the creation and manipulation of disk partition
tables, and it understands a variety of different formats.")
(license gpl3+)))

5
gnu/packages/gnome.scm
View file

@ -460,7 +460,6 @@ the API")
(sha256 (sha256
(base32 "1ya4d2j2aacr9ii5zj4ac95fjpdvlm2rg79mgnk7yvl1dcy3y1z5")) (base32 "1ya4d2j2aacr9ii5zj4ac95fjpdvlm2rg79mgnk7yvl1dcy3y1z5"))
(patches (list (patches (list
(search-patch "gtkglext-remove-pangox-dependency.patch")
(search-patch "gtkglext-disable-disable-deprecated.patch"))))) (search-patch "gtkglext-disable-disable-deprecated.patch")))))
(build-system gnu-build-system) (build-system gnu-build-system)
(inputs `(("gtk+" ,gtk+-2) (inputs `(("gtk+" ,gtk+-2)
@ -468,6 +467,7 @@ the API")
("libx11" ,libx11) ("libx11" ,libx11)
("libxt" ,libxt))) ("libxt" ,libxt)))
(native-inputs `(("pkg-config" ,pkg-config))) (native-inputs `(("pkg-config" ,pkg-config)))
(propagated-inputs `(("pangox-compat" ,pangox-compat)))
(home-page "https://projects.gnome.org/gtkglext") (home-page "https://projects.gnome.org/gtkglext")
(synopsis "OpenGL extension to GTK+.") (synopsis "OpenGL extension to GTK+.")
(description "GtkGLExt is an OpenGL extension to GTK+. It provides (description "GtkGLExt is an OpenGL extension to GTK+. It provides
@ -837,7 +837,8 @@ allows applications to access local and remote files with a single consistent AP
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append (uri (string-append
"mirror://gnome/sources/" name "/" (string-take version 3) "/" name "-" "mirror://gnome/sources/" name "/"
(string-take version 4) "/" name "-"
version version
".tar.bz2")) ".tar.bz2"))
(sha256 (sha256

4
gnu/packages/gnutls.scm
View file

@ -63,7 +63,7 @@ specifications.")
(define-public gnutls (define-public gnutls
(package (package
(name "gnutls") (name "gnutls")
(version "3.2.12") (version "3.2.15")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (uri
@ -75,7 +75,7 @@ specifications.")
"/gnutls-" version ".tar.xz")) "/gnutls-" version ".tar.xz"))
(sha256 (sha256
(base32 (base32
"0195nliarszq5mginli6d2f5z7ljnd7mwa46iy9z8pkcgy56khbl")))) "1fbpr9r1r2y803s3avwjpy1higqsz85dyb302kvmh0i29frwgg9h"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
;; Work around build issue reported at ;; Work around build issue reported at

62
gnu/packages/linux.scm
View file

@ -34,6 +34,7 @@
#:use-module (gnu packages python) #:use-module (gnu packages python)
#:use-module (gnu packages algebra) #:use-module (gnu packages algebra)
#:use-module (gnu packages gettext) #:use-module (gnu packages gettext)
#:use-module (gnu packages glib)
#:use-module (gnu packages pulseaudio) #:use-module (gnu packages pulseaudio)
#:use-module (gnu packages attr) #:use-module (gnu packages attr)
#:use-module (gnu packages xml) #:use-module (gnu packages xml)
@ -132,7 +133,9 @@
version ".tar.bz2")) version ".tar.bz2"))
(sha256 (sha256
(base32 (base32
"0jxnz9ahfic79rp93l5wxcbgh4pkv85mwnjlbv1gz3jawv5cvwp1")))) "0jxnz9ahfic79rp93l5wxcbgh4pkv85mwnjlbv1gz3jawv5cvwp1"))
(patches
(list (search-patch "module-init-tools-moduledir.patch")))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
;; FIXME: The upstream tarball lacks man pages, and building them would ;; FIXME: The upstream tarball lacks man pages, and building them would
@ -181,7 +184,8 @@
"CONFIG_VIRTIO_MMIO=m\n" "CONFIG_VIRTIO_MMIO=m\n"
"CONFIG_FUSE_FS=m\n" "CONFIG_FUSE_FS=m\n"
"CONFIG_CIFS=m\n" "CONFIG_CIFS=m\n"
"CONFIG_9P_FS=m\n") "CONFIG_9P_FS=m\n"
"CONFIG_E1000E=m\n")
port) port)
(close-port port)) (close-port port))
@ -316,15 +320,15 @@ providing the system administrator with some help in common tasks.")
(package (package
(name "util-linux") (name "util-linux")
(version "2.21") (version "2.21")
(source (source (origin
(origin (method url-fetch)
(method url-fetch) (uri (string-append "mirror://kernel.org/linux/utils/"
(uri (string-append "mirror://kernel.org/linux/utils/" name "/v" version "/"
name "/v" version "/" name "-" version ".2" ".tar.xz"))
name "-" version ".2" ".tar.xz")) (sha256
(sha256 (base32
(base32 "1rpgghf7n0zx0cdy8hibr41wvkm2qp1yvd8ab1rxr193l1jmgcir"))
"1rpgghf7n0zx0cdy8hibr41wvkm2qp1yvd8ab1rxr193l1jmgcir")))) (patches (list (search-patch "util-linux-perl.patch")))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
`(#:configure-flags '("--disable-use-tty-group" `(#:configure-flags '("--disable-use-tty-group"
@ -961,7 +965,15 @@ processes currently causing I/O.")
"/bin/" maybe-u "mount"))) "/bin/" maybe-u "mount")))
(substitute* '("util/mount.fuse.c") (substitute* '("util/mount.fuse.c")
(("/bin/sh") (("/bin/sh")
(which "sh")))) (which "sh")))
;; This hack leads libfuse to search for 'fusermount' in
;; $PATH, where it may find a setuid-root binary, instead of
;; trying solely $out/sbin/fusermount and failing because
;; it's not setuid.
(substitute* "lib/Makefile"
(("-DFUSERMOUNT_DIR=[[:graph:]]+")
"-DFUSERMOUNT_DIR=\\\"/var/empty\\\"")))
%standard-phases))) %standard-phases)))
(home-page "http://fuse.sourceforge.net/") (home-page "http://fuse.sourceforge.net/")
(synopsis "Support file systems implemented in user space") (synopsis "Support file systems implemented in user space")
@ -1033,6 +1045,32 @@ UnionFS-FUSE additionally supports copy-on-write.")
#:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static"))) #:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static")))
(inputs `(("fuse" ,fuse-static))))) (inputs `(("fuse" ,fuse-static)))))
(define-public sshfs-fuse
(package
(name "sshfs-fuse")
(version "2.5")
(source (origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/fuse/sshfs-fuse-"
version ".tar.gz"))
(sha256
(base32
"0gp6qr33l2p0964j0kds0dfmvyyf5lpgsn11daf0n5fhwm9185z9"))))
(build-system gnu-build-system)
(inputs
`(("fuse" ,fuse)
("glib" ,glib)))
(native-inputs
`(("pkg-config" ,pkg-config)))
(home-page "http://fuse.sourceforge.net/sshfs.html")
(synopsis "Mount remote file systems over SSH")
(description
"This is a file system client based on the SSH File Transfer Protocol.
Since most SSH servers already support this protocol it is very easy to set
up: on the server side there's nothing to do; on the client side mounting the
file system is as easy as logging into the server with an SSH client.")
(license gpl2+)))
(define-public numactl (define-public numactl
(package (package
(name "numactl") (name "numactl")

3
gnu/packages/maths.scm
View file

@ -253,7 +253,8 @@ plotting engine by third-party applications like Octave.")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (string-append "http://www.hdfgroup.org/ftp/HDF5/current/src/hdf5-" (uri (string-append "http://www.hdfgroup.org/ftp/HDF5/releases/hdf5-"
version "/src/hdf5-"
version ".tar.bz2")) version ".tar.bz2"))
(sha256 (sha256
(base32 "0f9n0v3p3lwc7564791a39c6cn1d3dbrn7d1j3ikqsi27a8hy23d")))) (base32 "0f9n0v3p3lwc7564791a39c6cn1d3dbrn7d1j3ikqsi27a8hy23d"))))

7
gnu/packages/openssl.scm
View file

@ -28,17 +28,14 @@
(define-public openssl (define-public openssl
(package (package
(name "openssl") (name "openssl")
(version "1.0.1g") (version "1.0.1h")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "ftp://ftp.openssl.org/source/openssl-" version (uri (string-append "ftp://ftp.openssl.org/source/openssl-" version
".tar.gz")) ".tar.gz"))
(sha256 (sha256
(base32 (base32
"0a70qdqccg16nw4bbawa6pjvzn05vfp5wkwg6jl0grch7f683jsk")) "14yhsgag5as7nhxnw7f0vklwjwa3pmn1i15nmp3f4qxa6sc8l74x"))))
(patches
(list (search-patch "openssl-CVE-2010-5298.patch")
(search-patch "openssl-extension-checking-fixes.patch")))))
(build-system gnu-build-system) (build-system gnu-build-system)
(native-inputs `(("perl" ,perl))) (native-inputs `(("perl" ,perl)))
(arguments (arguments

1
gnu/packages/package-management.scm
View file

@ -43,6 +43,7 @@
(arguments (arguments
`(#:configure-flags (list `(#:configure-flags (list
"--localstatedir=/var" "--localstatedir=/var"
"--sysconfdir=/etc"
(string-append "--with-libgcrypt-prefix=" (string-append "--with-libgcrypt-prefix="
(assoc-ref %build-inputs (assoc-ref %build-inputs
"libgcrypt"))) "libgcrypt")))

17
gnu/packages/patches/cssc-gets-undeclared.patch Normal file
View file

@ -0,0 +1,17 @@
CSSC uses a gets in a couple of places. For security reasons, modern gnulib
does not allow this. This patch allows it again.
--- CSSC-1.3.0/gl/lib/stdio.in.h 2010-05-15 00:15:35.000000000 +0200
+++ CSSC-1.3.0/gl/lib/stdio.in.h 2014-02-03 21:27:10.000000000 +0100
@@ -135,12 +135,6 @@
"use gnulib module fflush for portable POSIX compliance");
#endif
-/* It is very rare that the developer ever has full control of stdin,
- so any use of gets warrants an unconditional warning. Assume it is
- always declared, since it is required by C89. */
-#undef gets
-_GL_WARN_ON_USE (gets, "gets is a security hole - use fgets instead");
-
#if @GNULIB_FOPEN@
# if @REPLACE_FOPEN@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)

12
gnu/packages/patches/cssc-missing-include.patch Normal file
View file

@ -0,0 +1,12 @@
Added a missing include file (necessary for gid_t and others).
So far as I am aware, this has not been added upstream yet.
--- CSSC-1.3.0/src/file.h 2010-05-16 19:31:33.000000000 +0200
+++ CSSC-1.3.0/src/file.h 2014-02-03 21:48:30.000000000 +0100
@@ -30,6 +30,7 @@
#ifndef CSSC__FILE_H__
#define CSSC__FILE_H__
+#include <sys/types.h>
#include "filelock.h"
enum create_mode {

132
gnu/packages/patches/gtkglext-remove-pangox-dependency.patch
View file

@ -1,132 +0,0 @@
This patch removes the dependency on pangox which has been deprecated. It
achieves the same result as the upstream patch at
https://git.gnome.org/browse/gtkglext/commit/?id=df7a7b35b80b395d7ba411c7f727970a46fb0588
Like the upstream patch, it removes the functions gdk_gl_font_use_pango_font,
and gdk_gl_font_use_pango_font_for_display from the API.
diff -r -U 3 a/configure b/configure
--- a/configure 2006-02-05 04:17:47.000000000 +0100
+++ b/configure 2013-12-26 12:55:21.000000000 +0100
@@ -19880,14 +19880,12 @@
gtk+-2.0 >= 2.0.0 \\
gdk-2.0 >= 2.0.0 \\
pango >= 1.0.0 \\
-pangox >= 1.0.0 \\
gmodule-2.0 >= 2.0.0 \\
\"") >&5
($PKG_CONFIG --exists --print-errors "\
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
") 2>&5
ac_status=$?
@@ -19897,7 +19895,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
" 2>/dev/null`
else
@@ -19916,14 +19913,12 @@
gtk+-2.0 >= 2.0.0 \\
gdk-2.0 >= 2.0.0 \\
pango >= 1.0.0 \\
-pangox >= 1.0.0 \\
gmodule-2.0 >= 2.0.0 \\
\"") >&5
($PKG_CONFIG --exists --print-errors "\
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
") 2>&5
ac_status=$?
@@ -19933,7 +19928,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
" 2>/dev/null`
else
@@ -19958,7 +19952,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
"`
else
@@ -19966,7 +19959,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
"`
fi
@@ -19977,7 +19969,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
) were not met:
@@ -19994,7 +19985,6 @@
gtk+-2.0 >= 2.0.0 \
gdk-2.0 >= 2.0.0 \
pango >= 1.0.0 \
-pangox >= 1.0.0 \
gmodule-2.0 >= 2.0.0 \
) were not met:
@@ -25420,7 +25410,7 @@
# CFLAGS and LIBS
##################################################
-GDKGLEXT_PACKAGES="gdk-2.0 pango pangox gmodule-2.0"
+GDKGLEXT_PACKAGES="gdk-2.0 pango gmodule-2.0"
GDKGLEXT_EXTRA_CFLAGS="$GL_CFLAGS $GDKGLEXT_WIN_CFLAGS"
GDKGLEXT_EXTRA_LIBS="$GL_LIBS $GDKGLEXT_WIN_LIBS"
GDKGLEXT_DEP_CFLAGS="$GDKGLEXT_EXTRA_CFLAGS `$PKG_CONFIG --cflags $GDKGLEXT_PACKAGES`"
diff -r -U 3 a/gdk/x11/Makefile.in b/gdk/x11/Makefile.in
--- a/gdk/x11/Makefile.in 2006-02-05 04:17:42.000000000 +0100
+++ b/gdk/x11/Makefile.in 2013-12-26 13:12:04.000000000 +0100
@@ -257,7 +257,6 @@
gdkgldrawable-x11.c \
gdkglpixmap-x11.c \
gdkglwindow-x11.c \
- gdkglfont-x11.c \
gdkglglxext.c
@@ -288,7 +287,7 @@
am__objects_1 =
am__objects_2 = gdkglquery-x11.lo gdkglconfig-x11.lo gdkgloverlay-x11.lo \
gdkglcontext-x11.lo gdkgldrawable-x11.lo gdkglpixmap-x11.lo \
- gdkglwindow-x11.lo gdkglfont-x11.lo gdkglglxext.lo
+ gdkglwindow-x11.lo gdkglglxext.lo
am__objects_3 = $(am__objects_1) $(am__objects_2)
am_libgdkglext_x11_la_OBJECTS = $(am__objects_3)
libgdkglext_x11_la_OBJECTS = $(am_libgdkglext_x11_la_OBJECTS)
@@ -299,7 +298,6 @@
@AMDEP_TRUE@DEP_FILES = ./$(DEPDIR)/gdkglconfig-x11.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkglcontext-x11.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkgldrawable-x11.Plo \
-@AMDEP_TRUE@ ./$(DEPDIR)/gdkglfont-x11.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkglglxext.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkgloverlay-x11.Plo \
@AMDEP_TRUE@ ./$(DEPDIR)/gdkglpixmap-x11.Plo \
@@ -349,7 +347,6 @@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglconfig-x11.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglcontext-x11.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkgldrawable-x11.Plo@am__quote@
-@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglfont-x11.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglglxext.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkgloverlay-x11.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gdkglpixmap-x11.Plo@am__quote@

168
gnu/packages/patches/module-init-tools-moduledir.patch Normal file
View file

@ -0,0 +1,168 @@
This patch changes 'modprobe' & co. so they honor the 'LINUX_MODULE_DIRECTORY'
environment variable, rather than looking for modules exclusively in
/lib/modules.
Patch by David Guibert, from Nixpkgs; adjusted to use 'LINUX_MODULE_DIRECTORY'
rather than 'MODULE_DIR' as the variable name.
commit cf2c95edb7918bc658f6cae93793c1949fc9cb6e
Author: David Guibert <david.guibert@gmail.com>
Date: Fri Aug 5 14:20:12 2011 +0200
introduce module-dir
diff --git a/depmod.c b/depmod.c
index a1d2f8c..9362a35 100644
--- a/depmod.c
+++ b/depmod.c
@@ -48,9 +48,6 @@
#include "testing.h"
-#ifndef MODULE_DIR
-#define MODULE_DIR "/lib/modules/"
-#endif
#ifndef MODULE_BUILTIN_KEY
#define MODULE_BUILTIN_KEY "built-in"
@@ -1516,6 +1513,7 @@ static int parse_config_file(const char *filename,
char *line;
unsigned int linenum = 0;
FILE *cfile;
+ char *module_dir;
cfile = fopen(filename, "r");
if (!cfile) {
@@ -1525,6 +1523,10 @@ static int parse_config_file(const char *filename,
return 0;
}
+ if((module_dir = getenv("LINUX_MODULE_DIRECTORY")) == NULL) {
+ module_dir = "/lib/modules/";
+ }
+
while ((line = getline_wrapped(cfile, &linenum)) != NULL) {
char *ptr = line;
char *cmd, *modname;
@@ -1550,7 +1552,7 @@ static int parse_config_file(const char *filename,
continue;
}
nofail_asprintf(&dirname, "%s%s%s/%s", basedir,
- MODULE_DIR, kernelversion, search_path);
+ module_dir, kernelversion, search_path);
len = strlen(dirname);
*search = add_search(dirname, len, *search);
free(dirname);
@@ -1565,7 +1567,7 @@ static int parse_config_file(const char *filename,
continue;
nofail_asprintf(&pathname, "%s%s%s/%s/%s.ko", basedir,
- MODULE_DIR, kernelversion, subdir, modname);
+ module_dir, kernelversion, subdir, modname);
*overrides = add_override(pathname, *overrides);
free(pathname);
@@ -1737,6 +1739,7 @@ int main(int argc, char *argv[])
char *basedir = "", *dirname, *version;
char *system_map = NULL, *module_symvers = NULL;
int i;
+ char *module_dir;
const char *config = NULL;
if (native_endianness() == 0)
@@ -1832,7 +1835,11 @@ int main(int argc, char *argv[])
if (optind == argc)
all = 1;
- nofail_asprintf(&dirname, "%s%s%s", basedir, MODULE_DIR, version);
+ if((module_dir = getenv("LINUX_MODULE_DIRECTORY")) == NULL) {
+ module_dir = "/lib/modules/";
+ }
+
+ nofail_asprintf(&dirname, "%s%s%s", basedir, module_dir, version);
if (maybe_all) {
if (!doing_stdout && !depfile_out_of_date(dirname))
@@ -1850,7 +1857,7 @@ int main(int argc, char *argv[])
size_t len;
nofail_asprintf(&dirname, "%s%s%s/updates", basedir,
- MODULE_DIR, version);
+ module_dir, version);
len = strlen(dirname);
search = add_search(dirname, len, search);
}
diff --git a/modinfo.c b/modinfo.c
index 1dd8469..67b1041 100644
--- a/modinfo.c
+++ b/modinfo.c
@@ -19,9 +19,6 @@
#include "zlibsupport.h"
#include "testing.h"
-#ifndef MODULE_DIR
-#define MODULE_DIR "/lib/modules"
-#endif
struct param
{
@@ -193,6 +190,11 @@ static struct elf_file *grab_module(const char *name,
struct utsname buf;
char *depname, *p, *moddir;
struct elf_file *module;
+ char *module_dir;
+
+ if((module_dir = getenv("LINUX_MODULE_DIRECTORY")) == NULL) {
+ module_dir = "/lib/modules/";
+ }
if (strchr(name, '.') || strchr(name, '/')) {
module = grab_elf_file(name);
@@ -207,9 +209,9 @@ static struct elf_file *grab_module(const char *name,
kernel = buf.release;
}
if (strlen(basedir))
- nofail_asprintf(&moddir, "%s/%s/%s", basedir, MODULE_DIR, kernel);
+ nofail_asprintf(&moddir, "%s/%s/%s", basedir, module_dir, kernel);
else
- nofail_asprintf(&moddir, "%s/%s", MODULE_DIR, kernel);
+ nofail_asprintf(&moddir, "%s/%s", module_dir, kernel);
/* Search for it in modules.dep. */
nofail_asprintf(&depname, "%s/%s", moddir, "modules.dep");
diff --git a/modprobe.c b/modprobe.c
index 5464f45..d9fbf9d 100644
--- a/modprobe.c
+++ b/modprobe.c
@@ -86,10 +86,6 @@ typedef enum
} modprobe_flags_t;
-#ifndef MODULE_DIR
-#define MODULE_DIR "/lib/modules"
-#endif
-
/**
* print_usage - output the prefered program usage
*
@@ -2136,6 +2132,7 @@ int main(int argc, char *argv[])
struct modprobe_conf conf = {};
recursion_depth = 0;
+ char *module_dir = NULL;
/* Prepend options from environment. */
argv = merge_args(getenv("MODPROBE_OPTIONS"), argv, &argc);
@@ -2233,7 +2230,11 @@ int main(int argc, char *argv[])
if (argc < optind + 1 && !dump_config && !list_only)
print_usage(argv[0]);
- nofail_asprintf(&dirname, "%s%s/%s", basedir, MODULE_DIR, buf.release);
+ if((module_dir = getenv("LINUX_MODULE_DIRECTORY")) == NULL) {
+ module_dir = "/lib/modules";
+ }
+
+ nofail_asprintf(&dirname, "%s%s/%s", basedir, module_dir, buf.release);
/* Old-style -t xxx wildcard? Only with -l. */
if (list_only) {

27
gnu/packages/patches/openssl-CVE-2010-5298.patch
View file

@ -1,27 +0,0 @@
From db978be7388852059cf54e42539a363d549c5bfd Mon Sep 17 00:00:00 2001
From: Kurt Roeckx <kurt@roeckx.be>
Date: Sun, 13 Apr 2014 15:05:30 +0200
Subject: [PATCH] Don't release the buffer when there still is data in it
RT: 2167, 3265
---
ssl/s3_pkt.c | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/ssl/s3_pkt.c b/ssl/s3_pkt.c
index b9e45c7..32e9207 100644
--- a/ssl/s3_pkt.c
+++ b/ssl/s3_pkt.c
@@ -1055,7 +1055,8 @@ int ssl3_read_bytes(SSL *s, int type, unsigned char *buf, int len, int peek)
{
s->rstate=SSL_ST_READ_HEADER;
rr->off=0;
- if (s->mode & SSL_MODE_RELEASE_BUFFERS)
+ if (s->mode & SSL_MODE_RELEASE_BUFFERS &&
+ s->s3->rbuf.left == 0)
ssl3_release_read_buffer(s);
}
}
--
1.9.1

40
gnu/packages/patches/openssl-extension-checking-fixes.patch
View file

@ -1,40 +0,0 @@
From 300b9f0b704048f60776881f1d378c74d9c32fbd Mon Sep 17 00:00:00 2001
From: "Dr. Stephen Henson" <steve@openssl.org>
Date: Tue, 15 Apr 2014 18:48:54 +0100
Subject: [PATCH] Extension checking fixes.
When looking for an extension we need to set the last found
position to -1 to properly search all extensions.
PR#3309.
---
crypto/x509v3/v3_purp.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/crypto/x509v3/v3_purp.c b/crypto/x509v3/v3_purp.c
index 6c40c7d..5f931db 100644
--- a/crypto/x509v3/v3_purp.c
+++ b/crypto/x509v3/v3_purp.c
@@ -389,8 +389,8 @@ static void x509v3_cache_extensions(X509 *x)
/* Handle proxy certificates */
if((pci=X509_get_ext_d2i(x, NID_proxyCertInfo, NULL, NULL))) {
if (x->ex_flags & EXFLAG_CA
- || X509_get_ext_by_NID(x, NID_subject_alt_name, 0) >= 0
- || X509_get_ext_by_NID(x, NID_issuer_alt_name, 0) >= 0) {
+ || X509_get_ext_by_NID(x, NID_subject_alt_name, -1) >= 0
+ || X509_get_ext_by_NID(x, NID_issuer_alt_name, -1) >= 0) {
x->ex_flags |= EXFLAG_INVALID;
}
if (pci->pcPathLengthConstraint) {
@@ -670,7 +670,7 @@ static int check_purpose_timestamp_sign(const X509_PURPOSE *xp, const X509 *x,
return 0;
/* Extended Key Usage MUST be critical */
- i_ext = X509_get_ext_by_NID((X509 *) x, NID_ext_key_usage, 0);
+ i_ext = X509_get_ext_by_NID((X509 *) x, NID_ext_key_usage, -1);
if (i_ext >= 0)
{
X509_EXTENSION *ext = X509_get_ext((X509 *) x, i_ext);
--
1.9.1

15
gnu/packages/patches/util-linux-perl.patch Normal file
View file

@ -0,0 +1,15 @@
Use this common trick that exploits similarities between sh and Perl syntax
to avoid a hard dependency on Perl. Instead, this script will work only
when 'perl' is available in $PATH.
--- util-linux-2.21.2/misc-utils/chkdupexe.pl 2012-05-15 13:51:45.000000000 +0200
+++ util-linux-2.21.2/misc-utils/chkdupexe.pl 2014-06-01 22:46:06.000000000 +0200
@@ -1,5 +1,6 @@
-#!@PERL@ -w
-#
+eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}'
+ & eval 'exec perl -wS "$0" $argv:q'
+ if 0;
# chkdupexe version 2.1.1
#
# Simple script to look for and list duplicate executables and dangling

46
gnu/packages/version-control.scm
View file

@ -44,7 +44,8 @@
#:use-module (gnu packages emacs) #:use-module (gnu packages emacs)
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
#:use-module (gnu packages swig) #:use-module (gnu packages swig)
#:use-module (gnu packages tcl)) #:use-module (gnu packages tcl)
#:use-module (gnu packages))
(define-public bazaar (define-public bazaar
(package (package
@ -435,3 +436,46 @@ standards-compliant ChangeLog entries based on the changes that it detects.")
insertions, deletions, and modifications per-file. It is useful for reviewing insertions, deletions, and modifications per-file. It is useful for reviewing
large, complex patch files.") large, complex patch files.")
(license (x11-style "file://COPYING")))) (license (x11-style "file://COPYING"))))
(define-public cssc
(package
(name "cssc")
(version "1.3.0")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/" name "/CSSC-"
version ".tar.gz"))
(sha256
(base32
"0bkw6fjh20ppvn54smv05461lm1vcwvn02avx941c4acafmkl1cm"))
(patches (list (search-patch "cssc-gets-undeclared.patch")
(search-patch "cssc-missing-include.patch")))))
(build-system gnu-build-system)
(arguments
`(#:phases (alist-cons-before
'check 'precheck
(lambda _
(begin
(substitute* "tests/common/test-common"
(("/bin/pwd") (which "pwd")))
(substitute* "tests/prt/all-512.sh"
(("/bin/sh") (which "sh")))
;; XXX: This test has no hope of passing until there is a "nogroup"
;; entry (or at least some group to which the guix builder does
;; not belong) in the /etc/group file of the build environment.
;; Currently we do not have such a group. Disable this test for now.
(substitute* "tests/Makefile"
(("test-delta ") ""))))
%standard-phases)))
;; These are needed for the tests
(native-inputs `(("git" ,git)
("cvs" ,cvs)))
(home-page "http://www.gnu.org/software/cssc/")
(synopsis "File-based version control like SCCS")
(description "GNU CSSC provides a replacement for the legacy Unix source
code control system SCCS. This allows old code still under that system to be
accessed and migrated on modern systems.")
(license gpl3+)))

110
gnu/services/base.scm
View file

@ -17,6 +17,8 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services base) (define-module (gnu services base)
#:use-module ((guix store)
#:select (%store-prefix))
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu system shadow) ; 'user-account', etc. #:use-module (gnu system shadow) ; 'user-account', etc.
#:use-module (gnu system linux) ; 'pam-service', etc. #:use-module (gnu system linux) ; 'pam-service', etc.
@ -89,9 +91,11 @@ This service must be the root of the service dependency graph so that its
(respawn? #f))))) (respawn? #f)))))
(define* (file-system-service device target type (define* (file-system-service device target type
#:key (check? #t) options) #:key (check? #t) options (title 'any))
"Return a service that mounts DEVICE on TARGET as a file system TYPE with "Return a service that mounts DEVICE on TARGET as a file system TYPE with
OPTIONS. When CHECK? is true, check the file system before mounting it." OPTIONS. TITLE is a symbol specifying what kind of name DEVICE is: 'label for
a partition label, 'device for a device file name, or 'any. When CHECK? is
true, check the file system before mounting it."
(with-monad %store-monad (with-monad %store-monad
(return (return
(service (service
@ -99,10 +103,11 @@ OPTIONS. When CHECK? is true, check the file system before mounting it."
(requirement '(root-file-system)) (requirement '(root-file-system))
(documentation "Check, mount, and unmount the given file system.") (documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args (start #~(lambda args
#$(if check? (let ((device (canonicalize-device-spec #$device '#$title)))
#~(check-file-system #$device #$type) #$(if check?
#~#t) #~(check-file-system device #$type)
(mount #$device #$target #$type 0 #$options) #~#t)
(mount device #$target #$type 0 #$options))
#t)) #t))
(stop #~(lambda args (stop #~(lambda args
;; Normally there are no processes left at this point, so ;; Normally there are no processes left at this point, so
@ -193,9 +198,31 @@ stopped before 'kill' is called."
(define* (mingetty-service tty (define* (mingetty-service tty
#:key #:key
(motd (text-file "motd" "Welcome.\n")) (motd (text-file "motd" "Welcome.\n"))
auto-login
login-program
login-pause?
(allow-empty-passwords? #t)) (allow-empty-passwords? #t))
"Return a service to run mingetty on TTY." "Return a service to run mingetty on @var{tty}.
(mlet %store-monad ((motd motd))
When @var{allow-empty-passwords?} is true, allow empty log-in password. When
@var{auto-login} is true, it must be a user name under which to log-in
automatically. @var{login-pause?} can be set to @code{#t} in conjunction with
@var{auto-login}, in which case the user will have to press a key before the
login shell is launched.
When true, @var{login-program} is a gexp or a monadic gexp denoting the name
of the log-in program (the default is the @code{login} program from the Shadow
tool suite.)
@var{motd} is a monadic value containing a text file to use as
the \"message of the day\"."
(mlet %store-monad ((motd motd)
(login-program (cond ((gexp? login-program)
(return login-program))
((not login-program)
(return #f))
(else
login-program))))
(return (return
(service (service
(documentation (string-append "Run mingetty on " tty ".")) (documentation (string-append "Run mingetty on " tty "."))
@ -207,7 +234,16 @@ stopped before 'kill' is called."
(start #~(make-forkexec-constructor (start #~(make-forkexec-constructor
(string-append #$mingetty "/sbin/mingetty") (string-append #$mingetty "/sbin/mingetty")
"--noclear" #$tty)) "--noclear" #$tty
#$@(if auto-login
#~("--autologin" #$auto-login)
#~())
#$@(if login-program
#~("--loginprog" #$login-program)
#~())
#$@(if login-pause?
#~("--loginpause")
#~())))
(stop #~(make-kill-destructor)) (stop #~(make-kill-destructor))
(pam-services (pam-services
@ -243,11 +279,11 @@ stopped before 'kill' is called."
;; Snippet adapted from the GNU inetutils manual. ;; Snippet adapted from the GNU inetutils manual.
(define contents " (define contents "
# Log all kernel messages, authentication messages of # Log all error messages, authentication messages of
# level notice or higher and anything of level err or # level notice or higher and anything of level err or
# higher to the console. # higher to the console.
# Don't log private authentication messages! # Don't log private authentication messages!
*.err;kern.*;auth.notice;authpriv.none /dev/console *.err;auth.notice;authpriv.none /dev/console
# Log anything (except mail) of level info or higher. # Log anything (except mail) of level info or higher.
# Don't log private authentication messages! # Don't log private authentication messages!
@ -290,16 +326,57 @@ starting at FIRST-UID, and under GID."
(name (format #f "guixbuilder~2,'0d" n)) (name (format #f "guixbuilder~2,'0d" n))
(uid (+ first-uid n -1)) (uid (+ first-uid n -1))
(group group) (group group)
;; guix-daemon expects GROUP to be listed as a
;; supplementary group too:
;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
(supplementary-groups (list group))
(comment (format #f "Guix Build User ~2d" n)) (comment (format #f "Guix Build User ~2d" n))
(home-directory "/var/empty") (home-directory "/var/empty")
(shell #~(string-append #$shadow "/sbin/nologin")))) (shell #~(string-append #$shadow "/sbin/nologin"))))
1+ 1+
1)))) 1))))
(define (hydra-key-authorization guix)
"Return a gexp with code to register the hydra.gnu.org public key with
GUIX."
#~(unless (file-exists? "/etc/guix/acl")
(let ((pid (primitive-fork)))
(case pid
((0)
(let* ((key (string-append #$guix
"/share/guix/hydra.gnu.org.pub"))
(port (open-file key "r0b")))
(format #t "registering public key '~a'...~%" key)
(close-port (current-input-port))
(dup port 0)
(execl (string-append #$guix "/bin/guix")
"guix" "archive" "--authorize")
(exit 1)))
(else
(let ((status (cdr (waitpid pid))))
(unless (zero? status)
(format (current-error-port) "warning: \
failed to register hydra.gnu.org public key: ~a~%" status))))))))
(define* (guix-service #:key (guix guix) (builder-group "guixbuild") (define* (guix-service #:key (guix guix) (builder-group "guixbuild")
(build-accounts 10)) (build-accounts 10) authorize-hydra-key?)
"Return a service that runs the build daemon from GUIX, and has "Return a service that runs the build daemon from GUIX, and has
BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." BUILD-ACCOUNTS user accounts available under BUILD-USER-GID.
When AUTHORIZE-HYDRA-KEY? is true, the hydra.gnu.org public key provided by
GUIX is authorized upon activation, meaning that substitutes from
hydra.gnu.org are used by default."
(define activate
;; Assume that the store has BUILDER-GROUP as its group. We could
;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
;; chown leads to an entire copy of the tree, which is a bad idea.
;; Optionally authorize hydra.gnu.org's key.
(and authorize-hydra-key?
(hydra-key-authorization guix)))
(mlet %store-monad ((accounts (guix-build-accounts build-accounts (mlet %store-monad ((accounts (guix-build-accounts build-accounts
#:group builder-group))) #:group builder-group)))
(return (service (return (service
@ -315,7 +392,12 @@ BUILD-ACCOUNTS user accounts available under BUILD-USER-GID."
(user-groups (list (user-group (user-groups (list (user-group
(name builder-group) (name builder-group)
(members (map user-account-name (members (map user-account-name
user-accounts))))))))) user-accounts))
;; Use a fixed GID so that we can create the
;; store with the right owner.
(id 30000))))
(activate activate)))))
(define %base-services (define %base-services
;; Convenience variable holding the basic services. ;; Convenience variable holding the basic services.

2
gnu/services/dmd.scm
View file

@ -50,7 +50,7 @@
(use-modules (ice-9 ftw) (use-modules (ice-9 ftw)
(guix build syscalls) (guix build syscalls)
((guix build linux-initrd) ((guix build linux-initrd)
#:select (check-file-system))) #:select (check-file-system canonicalize-device-spec)))
(register-services (register-services
#$@(map (lambda (service) #$@(map (lambda (service)

77
gnu/system.scm
View file

@ -26,7 +26,11 @@
#:use-module (gnu packages base) #:use-module (gnu packages base)
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages linux)
#:use-module (gnu packages package-management) #:use-module (gnu packages package-management)
#:use-module (gnu packages which)
#:use-module (gnu packages less)
#:use-module (gnu packages zile)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services dmd) #:use-module (gnu services dmd)
#:use-module (gnu services base) #:use-module (gnu services base)
@ -50,6 +54,7 @@
operating-system-initrd operating-system-initrd
operating-system-users operating-system-users
operating-system-groups operating-system-groups
operating-system-issue
operating-system-packages operating-system-packages
operating-system-timezone operating-system-timezone
operating-system-locale operating-system-locale
@ -57,7 +62,9 @@
operating-system-derivation operating-system-derivation
operating-system-profile operating-system-profile
operating-system-grub.cfg)) operating-system-grub.cfg
%base-packages))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -91,17 +98,11 @@
(skeletons operating-system-skeletons ; list of name/monadic value (skeletons operating-system-skeletons ; list of name/monadic value
(default (default-skeletons))) (default (default-skeletons)))
(issue operating-system-issue ; string
(default %default-issue))
(packages operating-system-packages ; list of (PACKAGE OUTPUT...) (packages operating-system-packages ; list of (PACKAGE OUTPUT...)
(default (list coreutils ; or just PACKAGE (default %base-packages)) ; or just PACKAGE
grep
sed
findutils
guile
bash
(@ (gnu packages dmd) dmd)
guix
tzdata)))
(timezone operating-system-timezone) ; string (timezone operating-system-timezone) ; string
(locale operating-system-locale) ; string (locale operating-system-locale) ; string
@ -178,8 +179,10 @@ as 'needed-for-boot'."
(sequence %store-monad (sequence %store-monad
(map (match-lambda (map (match-lambda
(($ <file-system> device target type flags opts #f check?) (($ <file-system> device title target type flags opts
#f check?)
(file-system-service device target type (file-system-service device target type
#:title title
#:check? check? #:check? check?
#:options opts))) #:options opts)))
file-systems))) file-systems)))
@ -210,8 +213,25 @@ explicitly appear in OS."
;;; /etc. ;;; /etc.
;;; ;;;
(define %base-packages
;; Default set of packages globally visible. It should include anything
;; required for basic administrator tasks.
(list bash coreutils findutils grep sed
procps psmisc less zile
guile-final (@ (gnu packages admin) dmd) guix
util-linux inetutils isc-dhcp
net-tools ; XXX: remove when Inetutils suffices
module-init-tools kbd))
(define %default-issue
;; Default contents for /etc/issue.
"
This is the GNU system. Welcome.\n")
(define* (etc-directory #:key (define* (etc-directory #:key
kernel
(locale "C") (timezone "Europe/Paris") (locale "C") (timezone "Europe/Paris")
(issue "Hello!\n")
(skeletons '()) (skeletons '())
(pam-services '()) (pam-services '())
(profile "/run/current-system/profile") (profile "/run/current-system/profile")
@ -226,15 +246,7 @@ explicitly appear in OS."
/bin/sh /bin/sh
/run/current-system/profile/bin/sh /run/current-system/profile/bin/sh
/run/current-system/profile/bin/bash\n")) /run/current-system/profile/bin/bash\n"))
(issue (text-file "issue" " (issue (text-file "issue" issue))
This is an alpha preview of the GNU system. Welcome.
This image features the GNU Guix package manager, which was used to
build it (http://www.gnu.org/software/guix/). The init system is
GNU dmd (http://www.gnu.org/software/dmd/).
You can log in as 'guest' or 'root' with no password.
"))
;; TODO: Generate bashrc from packages' search-paths. ;; TODO: Generate bashrc from packages' search-paths.
(bashrc (text-file* "bashrc" " (bashrc (text-file* "bashrc" "
@ -244,8 +256,13 @@ export LC_ALL=\"" locale "\"
export TZ=\"" timezone "\" export TZ=\"" timezone "\"
export TZDIR=\"" tzdata "/share/zoneinfo\" export TZDIR=\"" tzdata "/share/zoneinfo\"
export PATH=/run/setuid-programs:/run/current-system/profile/sbin # Tell 'modprobe' & co. where to look for modules.
export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin:$PATH # XXX: The downside of doing it here is that when switching to a new config
# without rebooting, this variable possibly becomes invalid.
export LINUX_MODULE_DIRECTORY=" kernel "/lib/modules
export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin
export PATH=/run/setuid-programs:/run/current-system/profile/sbin:$PATH
export CPATH=$HOME/.guix-profile/include:" profile "/include export CPATH=$HOME/.guix-profile/include:" profile "/include
export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
alias ls='ls -p --color' alias ls='ls -p --color'
@ -306,8 +323,10 @@ alias ll='ls -l'
(append-map service-pam-services services)))) (append-map service-pam-services services))))
(profile-drv (operating-system-profile os)) (profile-drv (operating-system-profile os))
(skeletons (operating-system-skeletons os))) (skeletons (operating-system-skeletons os)))
(etc-directory #:pam-services pam-services (etc-directory #:kernel (operating-system-kernel os)
#:pam-services pam-services
#:skeletons skeletons #:skeletons skeletons
#:issue (operating-system-issue os)
#:locale (operating-system-locale os) #:locale (operating-system-locale os)
#:timezone (operating-system-timezone os) #:timezone (operating-system-timezone os)
#:sudoers (operating-system-sudoers os) #:sudoers (operating-system-sudoers os)
@ -319,7 +338,8 @@ alias ll='ls -l'
(list #~(string-append #$shadow "/bin/passwd") (list #~(string-append #$shadow "/bin/passwd")
#~(string-append #$shadow "/bin/su") #~(string-append #$shadow "/bin/su")
#~(string-append #$inetutils "/bin/ping") #~(string-append #$inetutils "/bin/ping")
#~(string-append #$sudo "/bin/sudo")))) #~(string-append #$sudo "/bin/sudo")
#~(string-append #$fuse "/bin/fusermount"))))
(define %sudoers-specification (define %sudoers-specification
;; Default /etc/sudoers contents: 'root' and all members of the 'wheel' ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
@ -382,7 +402,7 @@ etc."
(define group-specs (define group-specs
(map user-group->gexp groups)) (map user-group->gexp groups))
(gexp->file "boot" (gexp->file "activate"
#~(begin #~(begin
(eval-when (expand load eval) (eval-when (expand load eval)
;; Make sure 'use-modules' below succeeds. ;; Make sure 'use-modules' below succeeds.
@ -445,7 +465,7 @@ we're running in the final root."
(define (operating-system-root-file-system os) (define (operating-system-root-file-system os)
"Return the root file system of OS." "Return the root file system of OS."
(find (match-lambda (find (match-lambda
(($ <file-system> _ "/") #t) (($ <file-system> _ _ "/") #t)
(_ #f)) (_ #f))
(operating-system-file-systems os))) (operating-system-file-systems os)))
@ -453,9 +473,10 @@ we're running in the final root."
"Return a gexp denoting the initrd file of OS." "Return a gexp denoting the initrd file of OS."
(define boot-file-systems (define boot-file-systems
(filter (match-lambda (filter (match-lambda
(($ <file-system> device "/") (($ <file-system> device title "/")
#t) #t)
(($ <file-system> device mount-point type flags options boot?) (($ <file-system> device title mount-point type flags
options boot?)
boot?)) boot?))
(operating-system-file-systems os))) (operating-system-file-systems os)))

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

@ -22,6 +22,7 @@
file-system file-system
file-system? file-system?
file-system-device file-system-device
file-system-title
file-system-mount-point file-system-mount-point
file-system-type file-system-type
file-system-needed-for-boot? file-system-needed-for-boot?
@ -42,6 +43,8 @@
make-file-system make-file-system
file-system? file-system?
(device file-system-device) ; string (device file-system-device) ; string
(title file-system-title ; 'device | 'label | 'uuid
(default 'device))
(mount-point file-system-mount-point) ; string (mount-point file-system-mount-point) ; string
(type file-system-type) ; string (type file-system-type) ; string
(flags file-system-flags ; list of symbols (flags file-system-flags ; list of symbols

147
gnu/system/install.scm Normal file
View file

@ -0,0 +1,147 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system install)
#:use-module (gnu)
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (gnu packages linux)
#:use-module (gnu packages package-management)
#:use-module (gnu packages disk)
#:use-module (gnu packages texinfo)
#:export (installation-os))
;;; Commentary:
;;;
;;; This module provides an 'operating-system' definition for use on images
;;; for USB sticks etc., for the installation of the GNU system.
;;;
;;; Code:
(define (log-to-info)
"Return a script that spawns the Info reader on the right section of the
manual."
(gexp->script "log-to-info"
#~(execl (string-append #$texinfo-4 "/bin/info") "info"
"-d" "/run/current-system/profile/share/info"
"-f" (string-append #$guix "/share/info/guix.info")
"-n" "System Configuration")))
(define (installation-services)
"Return the list services for the installation image."
(let ((motd (text-file "motd" "
Welcome to the installation of the GNU operating system!
There is NO WARRANTY, to the extent permitted by law. In particular, you may
LOSE ALL YOUR DATA as a side effect of the installation process. Furthermore,
it is alpha software, so it may BREAK IN UNEXPECTED WAYS.
You have been warned. Thanks for being so brave.
")))
(define (normal-tty tty)
(mingetty-service tty
#:motd motd
#:auto-login "root"
#:login-pause? #t))
(list (mingetty-service "tty1"
#:motd motd
#:auto-login "root")
;; Documentation.
(mingetty-service "tty2"
#:motd motd
#:auto-login "guest"
#:login-program (log-to-info))
;; A bunch of 'root' ttys.
(normal-tty "tty3")
(normal-tty "tty4")
(normal-tty "tty5")
(normal-tty "tty6")
;; The usual services.
(syslog-service)
;; The build daemon. Register the hydra.gnu.org key as trusted.
;; This allows the installation process to use substitutes by
;; default.
(guix-service #:authorize-hydra-key? #t)
(nscd-service))))
(define %issue
;; Greeting.
"
This is an installation image of the GNU system. Welcome.
Use Alt-F2 for documentation.
")
(define installation-os
;; The operating system used on installation images for USB sticks etc.
(operating-system
(host-name "gnu")
(timezone "Europe/Paris")
(locale "en_US.UTF-8")
(bootloader (grub-configuration
(device "/dev/sda")))
(file-systems
;; Note: the disk image build code overrides this root file system with
;; the appropriate one.
(list (file-system
(mount-point "/")
(device "gnu-disk-image")
(type "ext4"))))
(users (list (user-account
(name "guest")
(group "wheel")
(password "")
(comment "Guest of GNU")
(home-directory "/home/guest"))))
(groups (list (user-group (name "root") (id 0))
(user-group
(name "wheel")
(id 1)
(members '("guest"))) ; allow 'guest' to use sudo
(user-group
(name "users")
(id 100)
(members '("guest")))))
(issue %issue)
(services (installation-services))
;; We don't need setuid programs so pass the empty list so we don't pull
;; additional programs here.
(setuid-programs '())
(pam-services
;; Explicitly allow for empty passwords.
(base-pam-services #:allow-empty-passwords? #t))
(packages (cons* texinfo-4 ; for the standalone Info reader
parted fdisk ddrescue
%base-packages))))
;; Return it here so 'guix system' can consume it directly.
installation-os
;;; install.scm ends here

4
gnu/system/linux-initrd.scm
View file

@ -198,8 +198,8 @@ a list of Guile module names to be embedded in the initrd."
"Return a list corresponding to file-system FS that can be passed to the "Return a list corresponding to file-system FS that can be passed to the
initrd code." initrd code."
(match fs (match fs
(($ <file-system> device mount-point type flags options _ check?) (($ <file-system> device title mount-point type flags options _ check?)
(list device mount-point type flags options check?)))) (list device title mount-point type flags options check?))))
(define* (qemu-initrd file-systems (define* (qemu-initrd file-systems
#:key #:key

29
gnu/system/vm.scm
View file

@ -29,7 +29,7 @@
#:use-module (gnu packages bash) #:use-module (gnu packages bash)
#:use-module (gnu packages less) #:use-module (gnu packages less)
#:use-module (gnu packages qemu) #:use-module (gnu packages qemu)
#:use-module (gnu packages parted) #:use-module (gnu packages disk)
#:use-module (gnu packages zile) #:use-module (gnu packages zile)
#:use-module (gnu packages grub) #:use-module (gnu packages grub)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
@ -196,15 +196,17 @@ made available under the /xchg CIFS share."
(disk-image-size (* 100 (expt 2 20))) (disk-image-size (* 100 (expt 2 20)))
(disk-image-format "qcow2") (disk-image-format "qcow2")
(file-system-type "ext4") (file-system-type "ext4")
file-system-label
grub-configuration grub-configuration
(register-closures? #t) (register-closures? #t)
(inputs '()) (inputs '())
copy-inputs?) copy-inputs?)
"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. The 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
returned image is a full disk image, with a GRUB installation that uses Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the partition. The returned image is a full disk image, with a GRUB installation
name of a file in the VM.) that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION
must be the name of a file in the VM.)
INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
@ -243,7 +245,8 @@ the image."
#:copy-closures? #$copy-inputs? #:copy-closures? #$copy-inputs?
#:register-closures? #$register-closures? #:register-closures? #$register-closures?
#:disk-image-size #$disk-image-size #:disk-image-size #$disk-image-size
#:file-system-type #$file-system-type) #:file-system-type #$file-system-type
#:file-system-label #$file-system-label)
(reboot)))) (reboot))))
#:system system #:system system
#:make-disk-image? #t #:make-disk-image? #t
@ -258,6 +261,7 @@ the image."
(define* (system-disk-image os (define* (system-disk-image os
#:key #:key
(name "disk-image")
(file-system-type "ext4") (file-system-type "ext4")
(disk-image-size (* 900 (expt 2 20))) (disk-image-size (* 900 (expt 2 20)))
(volatile? #t)) (volatile? #t))
@ -265,6 +269,12 @@ the image."
system described by OS. Said image can be copied on a USB stick as is. When system described by OS. Said image can be copied on a USB stick as is. When
VOLATILE? is true, the root file system is made volatile; this is useful VOLATILE? is true, the root file system is made volatile; this is useful
to USB sticks meant to be read-only." to USB sticks meant to be read-only."
(define root-label
;; Volume name of the root file system. Since we don't know which device
;; will hold it, we use the volume name to find it (using the UUID would
;; be even better, but somewhat less convenient.)
"gnu-disk-image")
(define file-systems-to-keep (define file-systems-to-keep
(remove (lambda (fs) (remove (lambda (fs)
(string=? (file-system-mount-point fs) "/")) (string=? (file-system-mount-point fs) "/"))
@ -280,16 +290,19 @@ to USB sticks meant to be read-only."
;; Force our own root file system. ;; Force our own root file system.
(file-systems (cons (file-system (file-systems (cons (file-system
(mount-point "/") (mount-point "/")
(device "/dev/sda1") (device root-label)
(title 'label)
(type file-system-type)) (type file-system-type))
file-systems-to-keep))))) file-systems-to-keep)))))
(mlet* %store-monad ((os-drv (operating-system-derivation os)) (mlet* %store-monad ((os-drv (operating-system-derivation os))
(grub.cfg (operating-system-grub.cfg os))) (grub.cfg (operating-system-grub.cfg os)))
(qemu-image #:grub-configuration grub.cfg (qemu-image #:name name
#:grub-configuration grub.cfg
#:disk-image-size disk-image-size #:disk-image-size disk-image-size
#:disk-image-format "raw" #:disk-image-format "raw"
#:file-system-type file-system-type #:file-system-type file-system-type
#:file-system-label root-label
#:copy-inputs? #t #:copy-inputs? #t
#:register-closures? #t #:register-closures? #t
#:inputs `(("system" ,os-drv) #:inputs `(("system" ,os-drv)

41
guix/build-system/gnu.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -265,7 +265,8 @@ System: GCC, GNU Make, Bash, Coreutils, etc."
(system (%current-system)) (system (%current-system))
(implicit-inputs? #t) ; useful when bootstrapping (implicit-inputs? #t) ; useful when bootstrapping
(imported-modules %default-modules) (imported-modules %default-modules)
(modules %default-modules)) (modules %default-modules)
allowed-references)
"Return a derivation called NAME that builds from tarball SOURCE, with "Return a derivation called NAME that builds from tarball SOURCE, with
input derivation INPUTS, using the usual procedure of the GNU Build input derivation INPUTS, using the usual procedure of the GNU Build
System. The builder is run with GUILE, or with the distro's final Guile System. The builder is run with GUILE, or with the distro's final Guile
@ -276,7 +277,10 @@ specifies modules not provided by Guile itself that must be imported in
the builder's environment, from the host. Note that we distinguish the builder's environment, from the host. Note that we distinguish
between both, because for Guile's own modules like (ice-9 foo), we want between both, because for Guile's own modules like (ice-9 foo), we want
to use GUILE's own version of it, rather than import the user's one, to use GUILE's own version of it, rather than import the user's one,
which could lead to gratuitous input divergence." which could lead to gratuitous input divergence.
ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs
are allowed to refer to."
(define implicit-inputs (define implicit-inputs
(and implicit-inputs? (and implicit-inputs?
(parameterize ((%store store)) (parameterize ((%store store))
@ -287,6 +291,16 @@ which could lead to gratuitous input divergence."
(standard-search-paths) (standard-search-paths)
'())) '()))
(define canonicalize-reference
(match-lambda
((? package? p)
(derivation->output-path (package-derivation store p system)))
(((? package? p) output)
(derivation->output-path (package-derivation store p system)
output))
((? string? output)
output)))
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
@ -337,6 +351,10 @@ which could lead to gratuitous input divergence."
outputs outputs
(delete "debug" outputs)) (delete "debug" outputs))
#:modules imported-modules #:modules imported-modules
#:allowed-references
(and allowed-references
(map canonicalize-reference
allowed-references))
#:guile-for-build guile-for-build)) #:guile-for-build guile-for-build))
@ -403,7 +421,8 @@ inputs."
(imported-modules '((guix build gnu-build-system) (imported-modules '((guix build gnu-build-system)
(guix build utils))) (guix build utils)))
(modules '((guix build gnu-build-system) (modules '((guix build gnu-build-system)
(guix build utils)))) (guix build utils)))
allowed-references)
"Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are
cross-built inputs, and NATIVE-INPUTS are inputs that run on the build cross-built inputs, and NATIVE-INPUTS are inputs that run on the build
platform." platform."
@ -428,6 +447,16 @@ platform."
(standard-cross-search-paths target 'target) (standard-cross-search-paths target 'target)
'())) '()))
(define canonicalize-reference
(match-lambda
((? package? p)
(derivation->output-path (package-cross-derivation store p system)))
(((? package? p) output)
(derivation->output-path (package-cross-derivation store p system)
output))
((? string? output)
output)))
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
@ -512,6 +541,10 @@ platform."
outputs outputs
(delete "debug" outputs)) (delete "debug" outputs))
#:modules imported-modules #:modules imported-modules
#:allowed-references
(and allowed-references
(map canonicalize-reference
allowed-references))
#:guile-for-build guile-for-build)) #:guile-for-build guile-for-build))
(define gnu-build-system (define gnu-build-system

3
guix/build/activation.scm
View file

@ -126,7 +126,8 @@ numeric gid or #f."
;; Then create the groups. ;; Then create the groups.
(for-each (match-lambda (for-each (match-lambda
((name password gid) ((name password gid)
(add-group name #:gid gid #:password password))) (unless (false-if-exception (getgrnam name))
(add-group name #:gid gid #:password password))))
groups) groups)
;; Finally create the other user accounts. ;; Finally create the other user accounts.

5
guix/build/install.scm
View file

@ -73,7 +73,10 @@ directory TARGET."
(define (directives store) (define (directives store)
"Return a list of directives to populate the root file system that will host "Return a list of directives to populate the root file system that will host
STORE." STORE."
`((directory ,store 0 0) `(;; Note: the store's GID is fixed precisely so we can set it here rather
;; than at activation time.
(directory ,store 0 30000)
(directory "/etc") (directory "/etc")
(directory "/var/log") ; for dmd (directory "/var/log") ; for dmd
(directory "/var/guix/gcroots") (directory "/var/guix/gcroots")

208
guix/build/linux-initrd.scm
View file

@ -18,12 +18,14 @@
(define-module (guix build linux-initrd) (define-module (guix build linux-initrd)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (system foreign) #:use-module (system foreign)
#:autoload (system repl repl) (start-repl) #:autoload (system repl repl) (start-repl)
#:autoload (system base compile) (compile-file) #:autoload (system base compile) (compile-file)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (guix build utils) #:use-module (guix build utils)
#:export (mount-essential-file-systems #:export (mount-essential-file-systems
@ -31,9 +33,16 @@
find-long-option find-long-option
make-essential-device-nodes make-essential-device-nodes
configure-qemu-networking configure-qemu-networking
disk-partitions
partition-label-predicate
find-partition-by-label
canonicalize-device-spec
check-file-system check-file-system
mount-file-system mount-file-system
bind-mount bind-mount
load-linux-module* load-linux-module*
device-number device-number
boot-system)) boot-system))
@ -88,6 +97,169 @@ Return the value associated with OPTION, or #f on failure."
(lambda (arg) (lambda (arg)
(substring arg (+ 1 (string-index arg #\=))))))) (substring arg (+ 1 (string-index arg #\=)))))))
(define-syntax %ext2-endianness
;; Endianness of ext2 file systems.
(identifier-syntax (endianness little)))
;; Offset in bytes of interesting parts of an ext2 superblock. See
;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
;; TODO: Use "packed structs" from Guile-OpenGL or similar.
(define-syntax %ext2-sblock-magic (identifier-syntax 56))
(define-syntax %ext2-sblock-creator-os (identifier-syntax 72))
(define-syntax %ext2-sblock-uuid (identifier-syntax 104))
(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
(define (read-ext2-superblock device)
"Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
if DEVICE does not contain an ext2 file system."
(define %ext2-magic
;; The magic bytes that identify an ext2 file system.
#xef53)
(call-with-input-file device
(lambda (port)
(seek port 1024 SEEK_SET)
(let* ((block (get-bytevector-n port 264))
(magic (bytevector-u16-ref block %ext2-sblock-magic
%ext2-endianness)))
(and (= magic %ext2-magic)
block)))))
(define (ext2-superblock-uuid sblock)
"Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
(let ((uuid (make-bytevector 16)))
(bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
uuid))
(define (ext2-superblock-volume-name sblock)
"Return the volume name of SBLOCK as a string of at most 16 characters, or
#f if SBLOCK has no volume name."
(let ((bv (make-bytevector 16)))
(bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
;; This is a Latin-1, nul-terminated string.
(let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
(if (null? bytes)
#f
(list->string (map integer->char bytes))))))
(define (disk-partitions)
"Return the list of device names corresponding to valid disk partitions."
(define (partition? major minor)
(let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
(catch 'system-error
(lambda ()
(not (zero? (call-with-input-file marker read))))
(lambda args
(if (= ENOENT (system-error-errno args))
#f
(apply throw args))))))
(call-with-input-file "/proc/partitions"
(lambda (port)
;; Skip the two header lines.
(read-line port)
(read-line port)
;; Read each subsequent line, and extract the last space-separated
;; field.
(let loop ((parts '()))
(let ((line (read-line port)))
(if (eof-object? line)
(reverse parts)
(match (string-tokenize line)
(((= string->number major) (= string->number minor)
blocks name)
(if (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 (find-partition-by-label label)
"Return the first partition found whose volume name is LABEL, or #f if none
were found."
(and=> (find (partition-label-predicate label)
(disk-partitions))
(cut string-append "/dev/" <>)))
(define* (canonicalize-device-spec spec #:optional (title 'any))
"Return the device name corresponding to SPEC. TITLE is a symbol, one of
the following:
• 'device', in which case SPEC is known to designate a device node--e.g.,
\"/dev/sda1\";
• 'label', in which case SPEC is known to designate a partition label--e.g.,
\"my-root-part\";
• 'any', in which case SPEC can be anything.
"
(define max-trials
;; Number of times we retry partition label resolution.
7)
(define canonical-title
;; The realm of canonicalization.
(if (eq? title 'any)
(if (string-prefix? "/" spec)
'device
'label)
title))
(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)
(begin
(format (current-error-port)
"failed to resolve partition label: ~s~%" spec)
(start-repl))
(begin
(sleep 1)
(loop (+ 1 count))))))))
;; TODO: Add support for UUIDs.
(else
(error "unknown device title" title))))
(define* (make-disk-device-nodes base major #:optional (minor 0))
"Make the block device nodes around BASE (something like \"/root/dev/sda\")
with the given MAJOR number, starting with MINOR."
(mknod base 'block-special #o644 (device-number major minor))
(let loop ((i 1))
(when (< i 6)
(mknod (string-append base (number->string i))
'block-special #o644 (device-number major (+ minor i)))
(loop (+ i 1)))))
(define* (make-essential-device-nodes #:key (root "/")) (define* (make-essential-device-nodes #:key (root "/"))
"Make essential device nodes under ROOT/dev." "Make essential device nodes under ROOT/dev."
;; The hand-made udev! ;; The hand-made udev!
@ -103,14 +275,17 @@ Return the value associated with OPTION, or #f on failure."
(mkdir (scope "dev"))) (mkdir (scope "dev")))
;; Make the device nodes for SCSI disks. ;; Make the device nodes for SCSI disks.
(mknod (scope "dev/sda") 'block-special #o644 (device-number 8 0)) (make-disk-device-nodes (scope "dev/sda") 8)
(mknod (scope "dev/sda1") 'block-special #o644 (device-number 8 1)) (make-disk-device-nodes (scope "dev/sdb") 8 16)
(mknod (scope "dev/sda2") 'block-special #o644 (device-number 8 2)) (make-disk-device-nodes (scope "dev/sdc") 8 32)
(make-disk-device-nodes (scope "dev/sdd") 8 48)
;; SCSI CD-ROM devices (aka. "/dev/sr0" etc.).
(mknod (scope "dev/scd0") 'block-special #o644 (device-number 11 0))
(mknod (scope "dev/scd1") 'block-special #o644 (device-number 11 1))
;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM. ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM.
(mknod (scope "dev/vda") 'block-special #o644 (device-number 252 0)) (make-disk-device-nodes (scope "dev/vda") 252)
(mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1))
(mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2))
;; Memory (used by Xorg's VESA driver.) ;; Memory (used by Xorg's VESA driver.)
(mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1)) (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1))
@ -123,6 +298,12 @@ Return the value associated with OPTION, or #f on failure."
(mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32)) (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32))
(mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64)) (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64))
;; System console. This node is magically created by the kernel on the
;; initrd's root, so don't try to create it in that case.
(unless (string=? root "/")
(mknod (scope "dev/console") 'char-special #o600
(device-number 5 1)))
;; TTYs. ;; TTYs.
(mknod (scope "dev/tty") 'char-special #o600 (mknod (scope "dev/tty") 'char-special #o600
(device-number 5 0)) (device-number 5 0))
@ -305,7 +486,7 @@ UNIONFS."
"Mount the file system described by SPEC under ROOT. SPEC must have the "Mount the file system described by SPEC under ROOT. SPEC must have the
form: form:
(DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
@ -320,8 +501,9 @@ run a file system check."
0))) 0)))
(match spec (match spec
((source mount-point type (flags ...) options check?) ((source title mount-point type (flags ...) options check?)
(let ((mount-point (string-append root "/" mount-point))) (let ((source (canonicalize-device-spec source title))
(mount-point (string-append root "/" mount-point)))
(when check? (when check?
(check-file-system source type)) (check-file-system source type))
(mkdir-p mount-point) (mkdir-p mount-point)
@ -381,6 +563,7 @@ bailing out.~%root contents: ~s~%" (scandir "/"))
(close-port console)))) (close-port console))))
(define* (boot-system #:key (define* (boot-system #:key
(linux-modules '()) (linux-modules '())
qemu-guest-networking? qemu-guest-networking?
@ -414,12 +597,12 @@ to it are lost."
(define root-mount-point? (define root-mount-point?
(match-lambda (match-lambda
((device "/" _ ...) #t) ((device _ "/" _ ...) #t)
(_ #f))) (_ #f)))
(define root-fs-type (define root-fs-type
(or (any (match-lambda (or (any (match-lambda
((device "/" type _ ...) type) ((device _ "/" type _ ...) type)
(_ #f)) (_ #f))
mounts) mounts)
"ext4")) "ext4"))
@ -451,7 +634,8 @@ to it are lost."
(unless (file-exists? "/root") (unless (file-exists? "/root")
(mkdir "/root")) (mkdir "/root"))
(if root (if root
(mount-root-file-system root root-fs-type (mount-root-file-system (canonicalize-device-spec root)
root-fs-type
#:volatile-root? volatile-root?) #:volatile-root? volatile-root?)
(mount "none" "/root" "tmpfs")) (mount "none" "/root" "tmpfs"))

25
guix/build/vm.scm
View file

@ -158,10 +158,16 @@ REFERENCE-GRAPHS, a list of reference-graph files."
(define MS_BIND 4096) ; <sys/mounts.h> again! (define MS_BIND 4096) ; <sys/mounts.h> again!
(define (format-partition partition type) (define* (format-partition partition type
"Create a file system TYPE on PARTITION." #:key label)
"Create a file system TYPE on PARTITION. If LABEL is true, use that as the
volume name."
(format #t "creating ~a partition...\n" type) (format #t "creating ~a partition...\n" type)
(unless (zero? (system* (string-append "mkfs." type) "-F" partition)) (unless (zero? (apply system* (string-append "mkfs." type)
"-F" partition
(if label
`("-L" ,label)
'())))
(error "failed to create partition"))) (error "failed to create partition")))
(define* (initialize-root-partition target-directory (define* (initialize-root-partition target-directory
@ -204,13 +210,15 @@ REFERENCE-GRAPHS, a list of reference-graph files."
grub.cfg grub.cfg
disk-image-size disk-image-size
(file-system-type "ext4") (file-system-type "ext4")
file-system-label
(closures '()) (closures '())
copy-closures? copy-closures?
(register-closures? #t)) (register-closures? #t))
"Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE
FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with
true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is GRUB installed. If REGISTER-CLOSURES? is true, register all of CLOSURES is
true, copy all of CLOSURES to the partition." the partition's store. If COPY-CLOSURES? is true, copy all of CLOSURES to the
partition."
(define target-directory (define target-directory
"/fs") "/fs")
@ -220,7 +228,8 @@ true, copy all of CLOSURES to the partition."
(initialize-partition-table device (initialize-partition-table device
(- disk-image-size (* 5 (expt 2 20)))) (- disk-image-size (* 5 (expt 2 20))))
(format-partition partition file-system-type) (format-partition partition file-system-type
#:label file-system-label)
(display "mounting partition...\n") (display "mounting partition...\n")
(mkdir target-directory) (mkdir target-directory)

23
guix/derivations.scm
View file

@ -565,7 +565,7 @@ HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for
(system (%current-system)) (env-vars '()) (system (%current-system)) (env-vars '())
(inputs '()) (outputs '("out")) (inputs '()) (outputs '("out"))
hash hash-algo recursive? hash hash-algo recursive?
references-graphs references-graphs allowed-references
local-build?) local-build?)
"Build a derivation with the given arguments, and return the resulting "Build a derivation with the given arguments, and return the resulting
<derivation> object. When HASH and HASH-ALGO are given, a <derivation> object. When HASH and HASH-ALGO are given, a
@ -578,6 +578,9 @@ When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs. In that case, the reference graph of each store path is exported in pairs. In that case, the reference graph of each store path is exported in
the build environment in the corresponding file, in a simple text format. the build environment in the corresponding file, in a simple text format.
When ALLOWED-REFERENCES is true, it must be a list of store items or outputs
that the derivation's output may refer to.
When LOCAL-BUILD? is true, declare that the derivation is not a good candidate When LOCAL-BUILD? is true, declare that the derivation is not a good candidate
for offloading and should rather be built locally. This is the case for small for offloading and should rather be built locally. This is the case for small
derivations where the costs of data transfers would outweigh the benefits." derivations where the costs of data transfers would outweigh the benefits."
@ -615,10 +618,14 @@ derivations where the costs of data transfers would outweigh the benefits."
;; Some options are passed to the build daemon via the env. vars of ;; Some options are passed to the build daemon via the env. vars of
;; derivations (urgh!). We hide that from our API, but here is the place ;; derivations (urgh!). We hide that from our API, but here is the place
;; where we kludgify those options. ;; where we kludgify those options.
(let ((env-vars (if local-build? (let ((env-vars `(,@(if local-build?
`(("preferLocalBuild" . "1") `(("preferLocalBuild" . "1"))
,@env-vars) '())
env-vars))) ,@(if allowed-references
`(("allowedReferences"
. ,(string-join allowed-references)))
'())
,@env-vars)))
(match references-graphs (match references-graphs
(((file . path) ...) (((file . path) ...)
(let ((value (map (cut string-append <> " " <>) (let ((value (map (cut string-append <> " " <>)
@ -955,6 +962,7 @@ they can refer to each other."
(modules '()) (modules '())
guile-for-build guile-for-build
references-graphs references-graphs
allowed-references
local-build?) local-build?)
"Return a derivation that executes Scheme expression EXP as a builder "Return a derivation that executes Scheme expression EXP as a builder
for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV)
@ -974,8 +982,8 @@ EXP returns #f, the build is considered to have failed.
EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is
omitted or is #f, the value of the `%guile-for-build' fluid is used instead. omitted or is #f, the value of the `%guile-for-build' fluid is used instead.
See the `derivation' procedure for the meaning of REFERENCES-GRAPHS and See the `derivation' procedure for the meaning of REFERENCES-GRAPHS,
LOCAL-BUILD?." ALLOWED-REFERENCES, and LOCAL-BUILD?."
(define guile-drv (define guile-drv
(or guile-for-build (%guile-for-build))) (or guile-for-build (%guile-for-build)))
@ -1100,4 +1108,5 @@ LOCAL-BUILD?."
#:recursive? recursive? #:recursive? recursive?
#:outputs outputs #:outputs outputs
#:references-graphs references-graphs #:references-graphs references-graphs
#:allowed-references allowed-references
#:local-build? local-build?))) #:local-build? local-build?)))

4
guix/gexp.scm
View file

@ -351,6 +351,10 @@ its search path."
(gexp (gexp
(call-with-output-file (ungexp output) (call-with-output-file (ungexp output)
(lambda (port) (lambda (port)
;; Note: that makes a long shebang. When the store
;; is /gnu/store, that fits within the 128-byte
;; limit imposed by Linux, but that may go beyond
;; when running tests.
(format port (format port
"#!~a/bin/guile --no-auto-compile~%!#~%" "#!~a/bin/guile --no-auto-compile~%!#~%"
(ungexp guile)) (ungexp guile))

486
po/eo.po
View file

File diff suppressed because it is too large Load diff

37
tests/derivations.scm
View file

@ -390,6 +390,43 @@
((p2 . _) ((p2 . _)
(string<? p1 p2))))))))))))))) (string<? p1 p2)))))))))))))))
(test-assert "derivation #:allowed-references, ok"
(let ((drv (derivation %store "allowed" %bash
'("-c" "echo hello > $out")
#:inputs `((,%bash))
#:allowed-references '())))
(build-derivations %store (list drv))))
(test-assert "derivation #:allowed-references, not allowed"
(let* ((txt (add-text-to-store %store "foo" "Hello, world."))
(drv (derivation %store "disallowed" %bash
`("-c" ,(string-append "echo " txt "> $out"))
#:inputs `((,%bash) (,txt))
#:allowed-references '())))
(guard (c ((nix-protocol-error? c)
;; There's no specific error message to check for.
#t))
(build-derivations %store (list drv))
#f)))
(test-assert "derivation #:allowed-references, self allowed"
(let ((drv (derivation %store "allowed" %bash
'("-c" "echo $out > $out")
#:inputs `((,%bash))
#:allowed-references '("out"))))
(build-derivations %store (list drv))))
(test-assert "derivation #:allowed-references, self not allowed"
(let ((drv (derivation %store "disallowed" %bash
`("-c" ,"echo $out > $out")
#:inputs `((,%bash))
#:allowed-references '())))
(guard (c ((nix-protocol-error? c)
;; There's no specific error message to check for.
#t))
(build-derivations %store (list drv))
#f)))
(define %coreutils (define %coreutils
(false-if-exception (false-if-exception

8
tests/gexp.scm
View file

@ -211,6 +211,14 @@
(return (string=? (readlink (string-append out "/foo")) (return (string=? (readlink (string-append out "/foo"))
guile)))) guile))))
(define shebang
(string-append (derivation->output-path guile-for-build)
"/bin/guile --no-auto-compile"))
;; If we're going to hit the silly shebang limit (128 chars on Linux-based
;; systems), then skip the following test.
(test-skip (if (> (string-length shebang) 127) 1 0))
(test-assertm "gexp->script" (test-assertm "gexp->script"
(mlet* %store-monad ((n -> (random (expt 2 50))) (mlet* %store-monad ((n -> (random (expt 2 50)))
(exp -> (gexp (exp -> (gexp