nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into core-updates

This commit is contained in:
Ludovic Courtès 2014-06-06 17:23:14 +02:00
parent a4d48cc24d b15d79dfe6
commit 872c69d00e
45 changed files with 1579 additions and 745 deletions
Show Stats 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)
(gnu packages zile)
(gnu packages xorg)
(gnu packages admin)
(gnu packages guile)
(gnu packages bash)
(gnu packages linux)
(gnu packages less)
(gnu packages tor)
(gnu packages package-management)
(gnu packages avahi)
(gnu services networking)
(gnu services avahi)
(gnu services dbus)
(gnu services xorg))
(operating-system
(host-name "gnu")
(timezone "Europe/Paris")
(locale "en_US.UTF-8")
(bootloader (grub-configuration
(device "/dev/sda")))
(file-systems
@ -52,6 +48,7 @@
(type "dummy"))
;; %fuse-control-file-system ; needs fuse.ko
%binary-format-file-system))
(users (list (user-account
(name "guest")
(group "wheel")
@ -67,6 +64,17 @@
(name "users")
(id 100)
(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
#:default-user "guest")
@ -75,11 +83,12 @@
#:name-servers '("10.0.2.3")
#:gateway "10.0.2.2")
(avahi-service)
(dbus-service (list avahi))
%base-services))
(pam-services
;; Explicitly allow for empty passwords.
(base-pam-services #:allow-empty-passwords? #t))
(packages (list bash coreutils findutils grep sed
procps psmisc less
guile-2.0 dmd guix util-linux inetutils
xterm zile)))
(packages (cons* xterm avahi %base-packages)))

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

@ -55,6 +55,7 @@
(gnu packages make-bootstrap)
(gnu system)
(gnu system vm)
(gnu system install)
(srfi srfi-1)
(srfi srfi-26)
(ice-9 match))
@ -114,6 +115,12 @@ SYSTEM."
'("mips64el-linux-gnu"
"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)
"Return a list of jobs that build QEMU images for SYSTEM."
(define (->alist drv)
@ -130,24 +137,28 @@ system.")
(string->symbol system))))
`(,name . ,(cut ->alist drv))))
(if (string=? system "x86_64-linux")
(let* ((dir (dirname (assoc-ref (current-source-location) 'filename)))
(file (string-append dir "/demo-os.scm"))
(os (read-operating-system file))
(size (* 1400 (expt 2 20)))) ; 1.4GiB
(if (operating-system? os)
(list (->job 'qemu-image
(run-with-store store
(system-qemu-image os
#:disk-image-size size))))
'()))
(define MiB
(expt 2 20))
(if (member system '("x86_64-linux" "i686-linux"))
(list (->job 'qemu-image
(run-with-store store
(system-qemu-image (demo-os)
#:disk-image-size
(* 1400 MiB)))) ; 1.4 GiB
(->job 'usb-image
(run-with-store store
(system-disk-image installation-os
#:disk-image-size
(* 630 MiB)))))
'()))
(define (hydra-jobs store arguments)
"Return Hydra jobs."
(define systems
;; Systems we want to build for.
'("x86_64-linux" "i686-linux"))
'("x86_64-linux" "i686-linux"
"mips64el-linux"))
(define subset
(match (assoc-ref arguments 'subset)
@ -165,12 +176,22 @@ system.")
(and (string-prefix? "i686-" system)
(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)
(map (lambda (package)
(package-cross-job store (job-name package)
package target system))
%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.
(let ((base-packages (delete-duplicates

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

@ -4,7 +4,7 @@ exec guile -l "$0" \
(cdr (command-line)))'
!#
;;; 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>
;;;
;;; This file is part of GNU Guix.
@ -148,7 +148,8 @@ decreasing, is 1."
`(div "status: "
,(url "x86_64-linux") " "
,(url "i686-linux")))
,(url "i686-linux") " "
,(url "mips64el-linux")))
(define (package-logo 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] @
[#:recursive? #f] [#:inputs '()] [#:env-vars '()] @
[#: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
@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
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
good candidate for offloading and should rather be built locally
(@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 '()] @
[#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @
[#: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
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,
@ -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
@code{%guile-for-build} fluid is used instead.
See the @code{derivation} procedure for the meaning of @var{references-graphs}
and @var{local-build?}.
See the @code{derivation} procedure for the meaning of
@var{references-graphs}, @var{allowed-references}, and @var{local-build?}.
@end deffn
@noindent
@ -3113,14 +3117,8 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this:
@findex operating-system
@lisp
(use-modules (gnu) ; for 'user-account', '%base-services', etc.
(gnu services ssh) ; for 'lsh-service'
(gnu packages base) ; Coreutils, grep, etc.
(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
(gnu packages emacs) ; for 'emacs'
(gnu services ssh)) ; for 'lsh-service'
(define komputilo
(operating-system
@ -3130,7 +3128,7 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this:
(bootloader (grub-configuration
(device "/dev/sda")))
(file-systems (list (file-system
(device "/dev/disk/by-label/root")
(device "/dev/sda1") ; or partition label
(mount-point "/")
(type "ext3"))))
(users (list (user-account
@ -3139,22 +3137,21 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this:
(uid 1000) (gid 100)
(comment "Bob's sister")
(home-directory "/home/alice"))))
(packages (list coreutils bash guile-2.0
guix dmd
inetutils
findutils grep sed
procps psmisc
zile less))
(packages (cons emacs %base-packages))
(services (cons (lsh-service #:port 2222 #:allow-root-login? #t)
%base-services))))
@end lisp
This example should be self-describing. The @code{packages} field lists
packages provided by the various @code{(gnu packages ...)} modules above
(@pxref{Package Modules}). These are the packages that will be globally
visible on the system, for all user accounts---i.e., in every user's
@code{PATH} environment variable---in addition to the per-user profiles
(@pxref{Invoking guix package}).
packages that will be globally visible on the system, for all user
accounts---i.e., in every user's @code{PATH} environment variable---in
addition to the per-user profiles (@pxref{Invoking guix package}). The
@var{%base-packages} variables provides all the tools one would expect
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
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/dc.scm \
gnu/packages/dejagnu.scm \
gnu/packages/ddrescue.scm \
gnu/packages/dictionaries.scm \
gnu/packages/disk.scm \
gnu/packages/docbook.scm \
gnu/packages/doxygen.scm \
gnu/packages/dwm.scm \
gnu/packages/ed.scm \
gnu/packages/elf.scm \
gnu/packages/emacs.scm \
gnu/packages/fdisk.scm \
gnu/packages/file.scm \
gnu/packages/flex.scm \
gnu/packages/fltk.scm \
@ -177,7 +176,6 @@ GNU_SYSTEM_MODULES = \
gnu/packages/openssl.scm \
gnu/packages/package-management.scm \
gnu/packages/parallel.scm \
gnu/packages/parted.scm \
gnu/packages/patchutils.scm \
gnu/packages/pciutils.scm \
gnu/packages/pcre.scm \
@ -256,6 +254,7 @@ GNU_SYSTEM_MODULES = \
gnu/system.scm \
gnu/system/file-systems.scm \
gnu/system/grub.scm \
gnu/system/install.scm \
gnu/system/linux.scm \
gnu/system/linux-initrd.scm \
gnu/system/shadow.scm \
@ -279,6 +278,8 @@ dist_patch_DATA = \
gnu/packages/patches/coreutils-dummy-man.patch \
gnu/packages/patches/coreutils-skip-nohup.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/dbus-localstatedir.patch \
gnu/packages/patches/diffutils-gets-undeclared.patch \
@ -311,7 +312,6 @@ dist_patch_DATA = \
gnu/packages/patches/guile-relocatable.patch \
gnu/packages/patches/guix-test-networking.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/inkscape-stray-comma.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/mit-krb5-init-fix.patch \
gnu/packages/patches/mpc123-initialize-ao.patch \
gnu/packages/patches/openssl-CVE-2010-5298.patch \
gnu/packages/patches/openssl-extension-checking-fixes.patch \
gnu/packages/patches/module-init-tools-moduledir.patch \
gnu/packages/patches/patchelf-page-size.patch \
gnu/packages/patches/patchutils-xfail-gendiff-tests.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/tcsh-fix-autotest.patch \
gnu/packages/patches/teckit-cstdio.patch \
gnu/packages/patches/util-linux-perl.patch \
gnu/packages/patches/valgrind-glibc.patch \
gnu/packages/patches/vpnc-script.patch \
gnu/packages/patches/w3m-fix-compile.patch \

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+.
(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)
#:use-module (guix packages)
#:use-module (guix licenses)
#:use-module ((guix licenses)
#:renamer (symbol-prefix-proc 'license:))
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix build-system python)
#: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 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 ssh)
#:use-module (gnu packages xml)
#:use-module (srfi srfi-1))
(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
uses GnuPG to encrypt and/or sign these archives, they will be safe from
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.
(package (inherit gcc-boot0)
(name "gcc")
(location (source-properties->location (current-source-location)))
(arguments
`(#:guile ,%bootstrap-guile
#:implicit-inputs? #f

10
gnu/packages/bdb.scm
View File

@ -34,13 +34,21 @@
(sha256 (base32
"1f2g2612lf8djbwbwhxsvmffmf9d7693kh2l20195pqp0f9jmnfx"))))
(build-system gnu-build-system)
(outputs '("out" ; programs, libraries, headers
"doc")) ; 94 MiB of HTML docs
(arguments
'(#:tests? #f ; no check target available
#:phases
(alist-replace
'configure
(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?
(system* "./dist/configure"
(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.
This package is mostly for compatibility and historical interest.")
(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
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -16,7 +16,7 @@
;;; 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 parted)
(define-module (gnu packages disk)
#:use-module (guix licenses)
#:use-module (guix packages)
#:use-module (guix download)
@ -24,7 +24,10 @@
#:use-module (gnu packages check)
#:use-module (gnu packages gettext)
#: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
(package
@ -67,3 +70,52 @@
"GNU Parted is a package for creating and manipulating disk partition
tables. It includes a library and command-line utility.")
(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
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -47,8 +47,11 @@
(native-inputs `(("m4" ,m4)))
(inputs `(("zlib" ,zlib)))
(home-page "https://fedorahosted.org/elfutils/")
(synopsis #f)
(description #f)
(synopsis "Linker and ELF manipulation tools")
(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+.
(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
(base32 "1ya4d2j2aacr9ii5zj4ac95fjpdvlm2rg79mgnk7yvl1dcy3y1z5"))
(patches (list
(search-patch "gtkglext-remove-pangox-dependency.patch")
(search-patch "gtkglext-disable-disable-deprecated.patch")))))
(build-system gnu-build-system)
(inputs `(("gtk+" ,gtk+-2)
@ -468,6 +467,7 @@ the API")
("libx11" ,libx11)
("libxt" ,libxt)))
(native-inputs `(("pkg-config" ,pkg-config)))
(propagated-inputs `(("pangox-compat" ,pangox-compat)))
(home-page "https://projects.gnome.org/gtkglext")
(synopsis "OpenGL extension to GTK+.")
(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
(method url-fetch)
(uri (string-append
"mirror://gnome/sources/" name "/" (string-take version 3) "/" name "-"
"mirror://gnome/sources/" name "/"
(string-take version 4) "/" name "-"
version
".tar.bz2"))
(sha256

4
gnu/packages/gnutls.scm
View File

@ -63,7 +63,7 @@ specifications.")
(define-public gnutls
(package
(name "gnutls")
(version "3.2.12")
(version "3.2.15")
(source (origin
(method url-fetch)
(uri
@ -75,7 +75,7 @@ specifications.")
"/gnutls-" version ".tar.xz"))
(sha256
(base32
"0195nliarszq5mginli6d2f5z7ljnd7mwa46iy9z8pkcgy56khbl"))))
"1fbpr9r1r2y803s3avwjpy1higqsz85dyb302kvmh0i29frwgg9h"))))
(build-system gnu-build-system)
(arguments
;; 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 algebra)
#:use-module (gnu packages gettext)
#:use-module (gnu packages glib)
#:use-module (gnu packages pulseaudio)
#:use-module (gnu packages attr)
#:use-module (gnu packages xml)
@ -132,7 +133,9 @@
version ".tar.bz2"))
(sha256
(base32
"0jxnz9ahfic79rp93l5wxcbgh4pkv85mwnjlbv1gz3jawv5cvwp1"))))
"0jxnz9ahfic79rp93l5wxcbgh4pkv85mwnjlbv1gz3jawv5cvwp1"))
(patches
(list (search-patch "module-init-tools-moduledir.patch")))))
(build-system gnu-build-system)
(arguments
;; FIXME: The upstream tarball lacks man pages, and building them would
@ -181,7 +184,8 @@
"CONFIG_VIRTIO_MMIO=m\n"
"CONFIG_FUSE_FS=m\n"
"CONFIG_CIFS=m\n"
"CONFIG_9P_FS=m\n")
"CONFIG_9P_FS=m\n"
"CONFIG_E1000E=m\n")
port)
(close-port port))
@ -316,15 +320,15 @@ providing the system administrator with some help in common tasks.")
(package
(name "util-linux")
(version "2.21")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://kernel.org/linux/utils/"
name "/v" version "/"
name "-" version ".2" ".tar.xz"))
(sha256
(base32
"1rpgghf7n0zx0cdy8hibr41wvkm2qp1yvd8ab1rxr193l1jmgcir"))))
(source (origin
(method url-fetch)
(uri (string-append "mirror://kernel.org/linux/utils/"
name "/v" version "/"
name "-" version ".2" ".tar.xz"))
(sha256
(base32
"1rpgghf7n0zx0cdy8hibr41wvkm2qp1yvd8ab1rxr193l1jmgcir"))
(patches (list (search-patch "util-linux-perl.patch")))))
(build-system gnu-build-system)
(arguments
`(#:configure-flags '("--disable-use-tty-group"
@ -961,7 +965,15 @@ processes currently causing I/O.")
"/bin/" maybe-u "mount")))
(substitute* '("util/mount.fuse.c")
(("/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)))
(home-page "http://fuse.sourceforge.net/")
(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")))
(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
(package
(name "numactl")

3
gnu/packages/maths.scm
View File

@ -253,7 +253,8 @@ plotting engine by third-party applications like Octave.")
(source
(origin
(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"))
(sha256
(base32 "0f9n0v3p3lwc7564791a39c6cn1d3dbrn7d1j3ikqsi27a8hy23d"))))

7
gnu/packages/openssl.scm
View File

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

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

@ -43,6 +43,7 @@
(arguments
`(#:configure-flags (list
"--localstatedir=/var"
"--sysconfdir=/etc"
(string-append "--with-libgcrypt-prefix="
(assoc-ref %build-inputs
"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 compression)
#:use-module (gnu packages swig)
#:use-module (gnu packages tcl))
#:use-module (gnu packages tcl)
#:use-module (gnu packages))
(define-public bazaar
(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
large, complex patch files.")
(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/>.
(define-module (gnu services base)
#:use-module ((guix store)
#:select (%store-prefix))
#:use-module (gnu services)
#:use-module (gnu system shadow) ; 'user-account', 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)))))
(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
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
(return
(service
@ -99,10 +103,11 @@ OPTIONS. When CHECK? is true, check the file system before mounting it."
(requirement '(root-file-system))
(documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args
#$(if check?
#~(check-file-system #$device #$type)
#~#t)
(mount #$device #$target #$type 0 #$options)
(let ((device (canonicalize-device-spec #$device '#$title)))
#$(if check?
#~(check-file-system device #$type)
#~#t)
(mount device #$target #$type 0 #$options))
#t))
(stop #~(lambda args
;; Normally there are no processes left at this point, so
@ -193,9 +198,31 @@ stopped before 'kill' is called."
(define* (mingetty-service tty
#:key
(motd (text-file "motd" "Welcome.\n"))
auto-login
login-program
login-pause?
(allow-empty-passwords? #t))
"Return a service to run mingetty on TTY."
(mlet %store-monad ((motd motd))
"Return a service to run mingetty on @var{tty}.
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
(service
(documentation (string-append "Run mingetty on " tty "."))
@ -207,7 +234,16 @@ stopped before 'kill' is called."
(start #~(make-forkexec-constructor
(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))
(pam-services
@ -243,11 +279,11 @@ stopped before 'kill' is called."
;; Snippet adapted from the GNU inetutils manual.
(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
# higher to the console.
# 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.
# Don't log private authentication messages!
@ -290,16 +326,57 @@ starting at FIRST-UID, and under GID."
(name (format #f "guixbuilder~2,'0d" n))
(uid (+ first-uid n -1))
(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))
(home-directory "/var/empty")
(shell #~(string-append #$shadow "/sbin/nologin"))))
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")
(build-accounts 10))
(build-accounts 10) authorize-hydra-key?)
"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
#:group builder-group)))
(return (service
@ -315,7 +392,12 @@ BUILD-ACCOUNTS user accounts available under BUILD-USER-GID."
(user-groups (list (user-group
(name builder-group)
(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
;; Convenience variable holding the basic services.

2
gnu/services/dmd.scm
View File

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

77
gnu/system.scm
View File

@ -26,7 +26,11 @@
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages admin)
#:use-module (gnu packages linux)
#: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 dmd)
#:use-module (gnu services base)
@ -50,6 +54,7 @@
operating-system-initrd
operating-system-users
operating-system-groups
operating-system-issue
operating-system-packages
operating-system-timezone
operating-system-locale
@ -57,7 +62,9 @@
operating-system-derivation
operating-system-profile
operating-system-grub.cfg))
operating-system-grub.cfg
%base-packages))
;;; Commentary:
;;;
@ -91,17 +98,11 @@
(skeletons operating-system-skeletons ; list of name/monadic value
(default (default-skeletons)))
(issue operating-system-issue ; string
(default %default-issue))
(packages operating-system-packages ; list of (PACKAGE OUTPUT...)
(default (list coreutils ; or just PACKAGE
grep
sed
findutils
guile
bash
(@ (gnu packages dmd) dmd)
guix
tzdata)))
(default %base-packages)) ; or just PACKAGE
(timezone operating-system-timezone) ; string
(locale operating-system-locale) ; string
@ -178,8 +179,10 @@ as 'needed-for-boot'."
(sequence %store-monad
(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
#:title title
#:check? check?
#:options opts)))
file-systems)))
@ -210,8 +213,25 @@ explicitly appear in OS."
;;; /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
kernel
(locale "C") (timezone "Europe/Paris")
(issue "Hello!\n")
(skeletons '())
(pam-services '())
(profile "/run/current-system/profile")
@ -226,15 +246,7 @@ explicitly appear in OS."
/bin/sh
/run/current-system/profile/bin/sh
/run/current-system/profile/bin/bash\n"))
(issue (text-file "issue" "
This is an alpha preview of the GNU system. Welcome.
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.
"))
(issue (text-file "issue" issue))
;; TODO: Generate bashrc from packages' search-paths.
(bashrc (text-file* "bashrc" "
@ -244,8 +256,13 @@ export LC_ALL=\"" locale "\"
export TZ=\"" timezone "\"
export TZDIR=\"" tzdata "/share/zoneinfo\"
export PATH=/run/setuid-programs:/run/current-system/profile/sbin
export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin:$PATH
# Tell 'modprobe' & co. where to look for modules.
# 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 LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
alias ls='ls -p --color'
@ -306,8 +323,10 @@ alias ll='ls -l'
(append-map service-pam-services services))))
(profile-drv (operating-system-profile 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
#:issue (operating-system-issue os)
#:locale (operating-system-locale os)
#:timezone (operating-system-timezone os)
#:sudoers (operating-system-sudoers os)
@ -319,7 +338,8 @@ alias ll='ls -l'
(list #~(string-append #$shadow "/bin/passwd")
#~(string-append #$shadow "/bin/su")
#~(string-append #$inetutils "/bin/ping")
#~(string-append #$sudo "/bin/sudo"))))
#~(string-append #$sudo "/bin/sudo")
#~(string-append #$fuse "/bin/fusermount"))))
(define %sudoers-specification
;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
@ -382,7 +402,7 @@ etc."
(define group-specs
(map user-group->gexp groups))
(gexp->file "boot"
(gexp->file "activate"
#~(begin
(eval-when (expand load eval)
;; Make sure 'use-modules' below succeeds.
@ -445,7 +465,7 @@ we're running in the final root."
(define (operating-system-root-file-system os)
"Return the root file system of OS."
(find (match-lambda
(($ <file-system> _ "/") #t)
(($ <file-system> _ _ "/") #t)
(_ #f))
(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."
(define boot-file-systems
(filter (match-lambda
(($ <file-system> device "/")
(($ <file-system> device title "/")
#t)
(($ <file-system> device mount-point type flags options boot?)
(($ <file-system> device title mount-point type flags
options boot?)
boot?))
(operating-system-file-systems os)))

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

@ -22,6 +22,7 @@
file-system
file-system?
file-system-device
file-system-title
file-system-mount-point
file-system-type
file-system-needed-for-boot?
@ -42,6 +43,8 @@
make-file-system
file-system?
(device file-system-device) ; string
(title file-system-title ; 'device | 'label | 'uuid
(default 'device))
(mount-point file-system-mount-point) ; string
(type file-system-type) ; string
(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
initrd code."
(match fs
(($ <file-system> device mount-point type flags options _ check?)
(list device mount-point type flags options check?))))
(($ <file-system> device title mount-point type flags options _ check?)
(list device title mount-point type flags options check?))))
(define* (qemu-initrd file-systems
#:key

29
gnu/system/vm.scm
View File

@ -29,7 +29,7 @@
#:use-module (gnu packages bash)
#:use-module (gnu packages less)
#:use-module (gnu packages qemu)
#:use-module (gnu packages parted)
#:use-module (gnu packages disk)
#:use-module (gnu packages zile)
#:use-module (gnu packages grub)
#: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-format "qcow2")
(file-system-type "ext4")
file-system-label
grub-configuration
(register-closures? #t)
(inputs '())
copy-inputs?)
"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. The
returned image is a full disk image, with a GRUB installation that uses
GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the
name of a file in the VM.)
'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
partition. The returned image is a full disk image, with a GRUB installation
that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION
must be the name of a file in the VM.)
INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
@ -243,7 +245,8 @@ the image."
#:copy-closures? #$copy-inputs?
#:register-closures? #$register-closures?
#: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))))
#:system system
#:make-disk-image? #t
@ -258,6 +261,7 @@ the image."
(define* (system-disk-image os
#:key
(name "disk-image")
(file-system-type "ext4")
(disk-image-size (* 900 (expt 2 20)))
(volatile? #t))
@ -265,6 +269,12 @@ the image."
system described by OS. Said image can be copied on a USB stick as is. When
VOLATILE? is true, the root file system is made volatile; this is useful
to USB sticks meant to be read-only."
(define 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
(remove (lambda (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.
(file-systems (cons (file-system
(mount-point "/")
(device "/dev/sda1")
(device root-label)
(title 'label)
(type file-system-type))
file-systems-to-keep)))))
(mlet* %store-monad ((os-drv (operating-system-derivation os))
(grub.cfg (operating-system-grub.cfg os)))
(qemu-image #:grub-configuration grub.cfg
(qemu-image #:name name
#:grub-configuration grub.cfg
#:disk-image-size disk-image-size
#:disk-image-format "raw"
#:file-system-type file-system-type
#:file-system-label root-label
#:copy-inputs? #t
#:register-closures? #t
#:inputs `(("system" ,os-drv)

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

@ -1,5 +1,5 @@
;;; 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.
;;;
@ -265,7 +265,8 @@ System: GCC, GNU Make, Bash, Coreutils, etc."
(system (%current-system))
(implicit-inputs? #t) ; useful when bootstrapping
(imported-modules %default-modules)
(modules %default-modules))
(modules %default-modules)
allowed-references)
"Return a derivation called NAME that builds from tarball SOURCE, with
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
@ -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
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,
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
(and implicit-inputs?
(parameterize ((%store store))
@ -287,6 +291,16 @@ which could lead to gratuitous input divergence."
(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
`(begin
(use-modules ,@modules)
@ -337,6 +351,10 @@ which could lead to gratuitous input divergence."
outputs
(delete "debug" outputs))
#:modules imported-modules
#:allowed-references
(and allowed-references
(map canonicalize-reference
allowed-references))
#:guile-for-build guile-for-build))
@ -403,7 +421,8 @@ inputs."
(imported-modules '((guix build gnu-build-system)
(guix build utils)))
(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-built inputs, and NATIVE-INPUTS are inputs that run on the build
platform."
@ -428,6 +447,16 @@ platform."
(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
`(begin
(use-modules ,@modules)
@ -512,6 +541,10 @@ platform."
outputs
(delete "debug" outputs))
#:modules imported-modules
#:allowed-references
(and allowed-references
(map canonicalize-reference
allowed-references))
#:guile-for-build guile-for-build))
(define gnu-build-system

3
guix/build/activation.scm
View File

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

5
guix/build/install.scm
View File

@ -73,7 +73,10 @@ directory TARGET."
(define (directives store)
"Return a list of directives to populate the root file system that will host
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 "/var/log") ; for dmd
(directory "/var/guix/gcroots")

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

@ -18,12 +18,14 @@
(define-module (guix build linux-initrd)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
#:autoload (system repl repl) (start-repl)
#:autoload (system base compile) (compile-file)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 ftw)
#:use-module (guix build utils)
#:export (mount-essential-file-systems
@ -31,9 +33,16 @@
find-long-option
make-essential-device-nodes
configure-qemu-networking
disk-partitions
partition-label-predicate
find-partition-by-label
canonicalize-device-spec
check-file-system
mount-file-system
bind-mount
load-linux-module*
device-number
boot-system))
@ -88,6 +97,169 @@ Return the value associated with OPTION, or #f on failure."
(lambda (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 "/"))
"Make essential device nodes under ROOT/dev."
;; The hand-made udev!
@ -103,14 +275,17 @@ Return the value associated with OPTION, or #f on failure."
(mkdir (scope "dev")))
;; Make the device nodes for SCSI disks.
(mknod (scope "dev/sda") 'block-special #o644 (device-number 8 0))
(mknod (scope "dev/sda1") 'block-special #o644 (device-number 8 1))
(mknod (scope "dev/sda2") 'block-special #o644 (device-number 8 2))
(make-disk-device-nodes (scope "dev/sda") 8)
(make-disk-device-nodes (scope "dev/sdb") 8 16)
(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.
(mknod (scope "dev/vda") 'block-special #o644 (device-number 252 0))
(mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1))
(mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2))
(make-disk-device-nodes (scope "dev/vda") 252)
;; Memory (used by Xorg's VESA driver.)
(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/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.
(mknod (scope "dev/tty") 'char-special #o600
(device-number 5 0))
@ -305,7 +486,7 @@ UNIONFS."
"Mount the file system described by SPEC under ROOT. SPEC must have the
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;
FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
@ -320,8 +501,9 @@ run a file system check."
0)))
(match spec
((source mount-point type (flags ...) options check?)
(let ((mount-point (string-append root "/" mount-point)))
((source title mount-point type (flags ...) options check?)
(let ((source (canonicalize-device-spec source title))
(mount-point (string-append root "/" mount-point)))
(when check?
(check-file-system source type))
(mkdir-p mount-point)
@ -381,6 +563,7 @@ bailing out.~%root contents: ~s~%" (scandir "/"))
(close-port console))))
(define* (boot-system #:key
(linux-modules '())
qemu-guest-networking?
@ -414,12 +597,12 @@ to it are lost."
(define root-mount-point?
(match-lambda
((device "/" _ ...) #t)
((device _ "/" _ ...) #t)
(_ #f)))
(define root-fs-type
(or (any (match-lambda
((device "/" type _ ...) type)
((device _ "/" type _ ...) type)
(_ #f))
mounts)
"ext4"))
@ -451,7 +634,8 @@ to it are lost."
(unless (file-exists? "/root")
(mkdir "/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?)
(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 (format-partition partition type)
"Create a file system TYPE on PARTITION."
(define* (format-partition partition type
#: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)
(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")))
(define* (initialize-root-partition target-directory
@ -204,13 +210,15 @@ REFERENCE-GRAPHS, a list of reference-graph files."
grub.cfg
disk-image-size
(file-system-type "ext4")
file-system-label
(closures '())
copy-closures?
(register-closures? #t))
"Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a
FILE-SYSTEM-TYPE partition, and with GRUB installed. If REGISTER-CLOSURES? is
true, register all of CLOSURES is the partition's store. If COPY-CLOSURES? is
true, copy all of CLOSURES to the partition."
"Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a FILE-SYSTEM-TYPE
partition with (optionally) FILE-SYSTEM-LABEL as its volume name, and with
GRUB installed. If REGISTER-CLOSURES? is true, register all of CLOSURES is
the partition's store. If COPY-CLOSURES? is true, copy all of CLOSURES to the
partition."
(define target-directory
"/fs")
@ -220,7 +228,8 @@ true, copy all of CLOSURES to the partition."
(initialize-partition-table device
(- 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")
(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 '())
(inputs '()) (outputs '("out"))
hash hash-algo recursive?
references-graphs
references-graphs allowed-references
local-build?)
"Build a derivation with the given arguments, and return the resulting
<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
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
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."
@ -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
;; derivations (urgh!). We hide that from our API, but here is the place
;; where we kludgify those options.
(let ((env-vars (if local-build?
`(("preferLocalBuild" . "1")
,@env-vars)
env-vars)))
(let ((env-vars `(,@(if local-build?
`(("preferLocalBuild" . "1"))
'())
,@(if allowed-references
`(("allowedReferences"
. ,(string-join allowed-references)))
'())
,@env-vars)))
(match references-graphs
(((file . path) ...)
(let ((value (map (cut string-append <> " " <>)
@ -955,6 +962,7 @@ they can refer to each other."
(modules '())
guile-for-build
references-graphs
allowed-references
local-build?)
"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)
@ -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
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
LOCAL-BUILD?."
See the `derivation' procedure for the meaning of REFERENCES-GRAPHS,
ALLOWED-REFERENCES, and LOCAL-BUILD?."
(define guile-drv
(or guile-for-build (%guile-for-build)))
@ -1100,4 +1108,5 @@ LOCAL-BUILD?."
#:recursive? recursive?
#:outputs outputs
#:references-graphs references-graphs
#:allowed-references allowed-references
#:local-build? local-build?)))

4
guix/gexp.scm
View File

@ -351,6 +351,10 @@ its search path."
(gexp
(call-with-output-file (ungexp output)
(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
"#!~a/bin/guile --no-auto-compile~%!#~%"
(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 . _)
(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
(false-if-exception

8
tests/gexp.scm
View File

@ -211,6 +211,14 @@
(return (string=? (readlink (string-append out "/foo"))
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"
(mlet* %store-monad ((n -> (random (expt 2 50)))
(exp -> (gexp