summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
author宋文武 <iyzsong@gmail.com>2015-10-30 20:50:26 +0800
committer宋文武 <iyzsong@gmail.com>2015-10-30 20:50:26 +0800
commiteed588d9976367cac020d20de9a99d4bce0058b3 (patch)
tree449db39e73ec90151ec279ed1b403b189cabc2a0
parent9fa8f436696598e783407b16f0e459791fdd9970 (diff)
parentb90e7e5d49e951a24f58d3cd29d37127982ef240 (diff)
downloadpatches-eed588d9976367cac020d20de9a99d4bce0058b3.tar
patches-eed588d9976367cac020d20de9a99d4bce0058b3.tar.gz
Merge branch 'master' into dbus-update
-rw-r--r--.dir-locals.el1
-rw-r--r--Makefile.am1
-rw-r--r--doc/contributing.texi25
-rw-r--r--doc/emacs.texi2
-rw-r--r--doc/guix.texi246
-rw-r--r--emacs/guix-base.el2
-rw-r--r--emacs/guix-command.el5
-rw-r--r--emacs/guix-devel.el2
-rw-r--r--emacs/guix-pcomplete.el4
-rw-r--r--gnu-system.am2
-rw-r--r--gnu/build/linux-container.scm2
-rw-r--r--gnu/packages/algebra.scm2
-rw-r--r--gnu/packages/avahi.scm2
-rw-r--r--gnu/packages/backup.scm45
-rw-r--r--gnu/packages/bioinformatics.scm81
-rw-r--r--gnu/packages/cyrus-sasl.scm4
-rw-r--r--gnu/packages/databases.scm22
-rw-r--r--gnu/packages/emacs.scm8
-rw-r--r--gnu/packages/fish.scm4
-rw-r--r--gnu/packages/freeipmi.scm4
-rw-r--r--gnu/packages/gcc.scm10
-rw-r--r--gnu/packages/gdbm.scm46
-rw-r--r--gnu/packages/grub.scm32
-rw-r--r--gnu/packages/guile.scm8
-rw-r--r--gnu/packages/haskell.scm61
-rw-r--r--gnu/packages/java.scm18
-rw-r--r--gnu/packages/linux.scm8
-rw-r--r--gnu/packages/mail.scm2
-rw-r--r--gnu/packages/man.scm2
-rw-r--r--gnu/packages/maths.scm4
-rw-r--r--gnu/packages/package-management.scm137
-rw-r--r--gnu/packages/password-utils.scm32
-rw-r--r--gnu/packages/patches/xfce4-session-fix-xflock4.patch31
-rw-r--r--gnu/packages/pcre.scm35
-rw-r--r--gnu/packages/pulseaudio.scm2
-rw-r--r--gnu/packages/python.scm97
-rw-r--r--gnu/packages/ruby.scm3
-rw-r--r--gnu/packages/sawfish.scm2
-rw-r--r--gnu/packages/scheme.scm4
-rw-r--r--gnu/packages/video.scm172
-rw-r--r--gnu/packages/xfce.scm5
-rw-r--r--gnu/packages/xorg.scm42
-rw-r--r--gnu/services.scm101
-rw-r--r--gnu/services/base.scm22
-rw-r--r--gnu/services/desktop.scm6
-rw-r--r--gnu/services/xorg.scm55
-rw-r--r--gnu/system.scm26
-rw-r--r--gnu/system/file-systems.scm5
-rw-r--r--gnu/system/grub.scm57
-rw-r--r--gnu/system/linux-initrd.scm6
-rw-r--r--gnu/system/linux.scm3
-rw-r--r--guix/build/haskell-build-system.scm9
-rw-r--r--guix/gnu-maintenance.scm8
-rw-r--r--guix/import/cran.scm8
-rw-r--r--guix/import/elpa.scm8
-rw-r--r--guix/profiles.scm80
-rw-r--r--guix/scripts/build.scm50
-rw-r--r--guix/scripts/challenge.scm6
-rw-r--r--guix/scripts/environment.scm337
-rw-r--r--guix/scripts/package.scm208
-rw-r--r--guix/scripts/pull.scm1
-rw-r--r--guix/scripts/refresh.scm32
-rw-r--r--guix/scripts/size.scm3
-rwxr-xr-xguix/scripts/substitute.scm113
-rw-r--r--guix/scripts/system.scm248
-rw-r--r--guix/store.scm15
-rw-r--r--guix/ui.scm157
-rw-r--r--guix/upstream.scm15
-rw-r--r--guix/utils.scm36
-rw-r--r--po/guix/POTFILES.in2
-rw-r--r--tests/guix-build.sh27
-rw-r--r--tests/guix-environment-container.sh76
-rw-r--r--tests/guix-environment.sh14
-rw-r--r--tests/substitute.scm4
74 files changed, 2144 insertions, 811 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 54d5bdaefc..0873c1d747 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -23,6 +23,7 @@
(eval . (put 'lambda* 'scheme-indent-function 1))
(eval . (put 'substitute* 'scheme-indent-function 1))
(eval . (put 'modify-phases 'scheme-indent-function 1))
+ (eval . (put 'modify-services 'scheme-indent-function 1))
(eval . (put 'with-directory-excursion 'scheme-indent-function 1))
(eval . (put 'package 'scheme-indent-function 0))
(eval . (put 'origin 'scheme-indent-function 0))
diff --git a/Makefile.am b/Makefile.am
index 1427203fb2..4f90b1d15b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -253,6 +253,7 @@ SH_TESTS = \
tests/guix-archive.sh \
tests/guix-authenticate.sh \
tests/guix-environment.sh \
+ tests/guix-environment-container.sh \
tests/guix-graph.sh \
tests/guix-lint.sh
diff --git a/doc/contributing.texi b/doc/contributing.texi
index 245ce9b1c4..f855daf2da 100644
--- a/doc/contributing.texi
+++ b/doc/contributing.texi
@@ -27,6 +27,7 @@ the installation instructions (@pxref{Requirements}).
@item @url{http://gnu.org/software/autoconf/, GNU Autoconf};
@item @url{http://gnu.org/software/automake/, GNU Automake};
@item @url{http://gnu.org/software/gettext/, GNU Gettext};
+@item @url{http://gnu.org/software/texinfo/, GNU Texinfo};
@item @url{http://www.graphviz.org/, Graphviz};
@item @url{http://www.gnu.org/software/help2man/, GNU Help2man (optional)}.
@end itemize
@@ -86,6 +87,30 @@ Similarly, for a Guile session using the Guix modules:
@example
$ ./pre-inst-env guile -c '(use-modules (guix utils)) (pk (%current-system))'
+
+;;; ("x86_64-linux")
+@end example
+
+@noindent
+@cindex REPL
+@cindex read-eval-print loop
+@dots{} and for a REPL (@pxref{Using Guile Interactively,,, guile, Guile
+Reference Manual}):
+
+@example
+$ ./pre-inst-env guile
+scheme@@(guile-user)> ,use(guix)
+scheme@@(guile-user)> ,use(gnu)
+scheme@@(guile-user)> (define snakes
+ (fold-packages
+ (lambda (package lst)
+ (if (string-prefix? "python"
+ (package-name package))
+ (cons package lst)
+ lst))
+ '()))
+scheme@@(guile-user)> (length snakes)
+$1 = 361
@end example
The @command{pre-inst-env} script sets up all the environment variables
diff --git a/doc/emacs.texi b/doc/emacs.texi
index 0e901e1f90..b36e859b4a 100644
--- a/doc/emacs.texi
+++ b/doc/emacs.texi
@@ -227,6 +227,8 @@ prefix argument is used. This has the same meaning as @code{--manifest}
option (@pxref{Invoking guix package}).
@item C-c C-z
+@cindex REPL
+@cindex read-eval-print loop
Go to the Guix REPL (@pxref{The REPL,,, geiser, Geiser User Manual}).
@item h
diff --git a/doc/guix.texi b/doc/guix.texi
index 99c10d8dc7..236c5973cd 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -233,7 +233,8 @@ software packages, etc.
@cindex functional package management
The term @dfn{functional} refers to a specific package management
-discipline. In Guix, the package build and installation process is seen
+discipline pioneered by Nix (@pxref{Acknowledgments}).
+In Guix, the package build and installation process is seen
as a function, in the mathematical sense. That function takes inputs,
such as build scripts, a compiler, and libraries, and
returns an installed package. As a pure function, its result depends
@@ -3615,6 +3616,19 @@ The @var{options} may be zero or more of the following:
@table @code
+@item --file=@var{file}
+@itemx -f @var{file}
+
+Build the package or derivation that the code within @var{file}
+evaluates to.
+
+As an example, @var{file} might contain a package definition like this
+(@pxref{Defining Packages}):
+
+@example
+@verbatiminclude package-hello.scm
+@end example
+
@item --expression=@var{expr}
@itemx -e @var{expr}
Build the package or derivation @var{expr} evaluates to.
@@ -4263,8 +4277,8 @@ inconvenient.
@item --type=@var{updater}
@itemx -t @var{updater}
-Select only packages handled by @var{updater}. Currently, @var{updater}
-may be one of:
+Select only packages handled by @var{updater} (may be a comma-separated
+list of updaters). Currently, @var{updater} may be one of:
@table @code
@item gnu
@@ -4279,7 +4293,7 @@ For instance, the following commands only checks for updates of Emacs
packages hosted at @code{elpa.gnu.org} and updates of CRAN packages:
@example
-$ guix refresh -t elpa -t cran
+$ guix refresh --type=elpa,cran
gnu/packages/statistics.scm:819:13: r-testthat would be upgraded from 0.10.0 to 0.11.0
gnu/packages/emacs.scm:856:13: emacs-auctex would be upgraded from 11.88.6 to 11.88.9
@end example
@@ -4305,6 +4319,10 @@ be used when passing @command{guix refresh} one or more package names:
@table @code
+@item --list-updaters
+@itemx -L
+List available updaters and exit (see @option{--type} above.)
+
@item --list-dependent
@itemx -l
List top-level dependent packages that would need to be rebuilt as a
@@ -4681,6 +4699,32 @@ NumPy:
guix environment --ad-hoc python2-numpy python-2.7 -- python
@end example
+Furthermore, one might want the dependencies of a package and also some
+additional packages that are not build-time or runtime dependencies, but
+are useful when developing nonetheless. Because of this, the
+@code{--ad-hoc} flag is positional. Packages appearing before
+@code{--ad-hoc} are interpreted as packages whose dependencies will be
+added to the environment. Packages appearing after are interpreted as
+packages that will be added to the environment directly. For example,
+the following command creates a Guix development environment that
+additionally includes Git and strace:
+
+@example
+guix environment guix --ad-hoc git strace
+@end example
+
+Sometimes it is desirable to isolate the environment as much as
+possible, for maximal purity and reproducibility. In particular, when
+using Guix on a host distro that is not GuixSD, it is desirable to
+prevent access to @file{/usr/bin} and other system-wide resources from
+the development environment. For example, the following command spawns
+a Guile REPL in a ``container'' where only the store and the current
+working directory are mounted:
+
+@example
+guix environment --ad-hoc --container guile -- guile
+@end example
+
The available options are summarized below.
@table @code
@@ -4729,6 +4773,12 @@ Note that this example implicitly asks for the default output of
specific output---e.g., @code{glib:bin} asks for the @code{bin} output
of @code{glib} (@pxref{Packages with Multiple Outputs}).
+This option may be composed with the default behavior of @command{guix
+environment}. Packages appearing before @code{--ad-hoc} are interpreted
+as packages whose dependencies will be added to the environment, the
+default behavior. Packages appearing after are interpreted as packages
+that will be added to the environment directly.
+
@item --pure
Unset existing environment variables when building the new environment.
This has the effect of creating an environment in which search paths
@@ -4741,6 +4791,49 @@ environment.
@item --system=@var{system}
@itemx -s @var{system}
Attempt to build for @var{system}---e.g., @code{i686-linux}.
+
+@item --container
+@itemx -C
+@cindex container
+Run @var{command} within an isolated container. The current working
+directory outside the container is mapped to @file{/env} inside the
+container. Additionally, the spawned process runs as the current user
+outside the container, but has root privileges in the context of the
+container.
+
+@item --network
+@itemx -N
+For containers, share the network namespace with the host system.
+Containers created without this flag only have access to the loopback
+device.
+
+@item --expose=@var{source}[=@var{target}]
+For containers, expose the file system @var{source} from the host system
+as the read-only file system @var{target} within the container. If
+@var{target} is not specified, @var{source} is used as the target mount
+point in the container.
+
+The example below spawns a Guile REPL in a container in which the user's
+home directory is accessible read-only via the @file{/exchange}
+directory:
+
+@example
+guix environment --container --expose=$HOME=/exchange guile -- guile
+@end example
+
+@item --share
+For containers, share the file system @var{source} from the host system
+as the writable file system @var{target} within the container. If
+@var{target} is not specified, @var{source} is used as the target mount
+point in the container.
+
+The example below spawns a Guile REPL in a container in which the user's
+home directory is accessible for both reading and writing via the
+@file{/exchange} directory:
+
+@example
+guix environment --container --share=$HOME=/exchange guile -- guile
+@end example
@end table
It also supports all of the common build options that @command{guix
@@ -5283,7 +5376,7 @@ addition to the per-user profiles (@pxref{Invoking guix package}). The
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
+tcpdump to those, taken from the @code{(gnu packages admin)} module
(@pxref{Package Modules}).
@vindex %base-services
@@ -5291,16 +5384,40 @@ The @code{services} field lists @dfn{system services} to be made
available when the system starts (@pxref{Services}).
The @code{operating-system} declaration above specifies that, in
addition to the basic services, we want the @command{lshd} secure shell
-daemon listening on port 2222, and allowing remote @code{root} logins
-(@pxref{Invoking lshd,,, lsh, GNU lsh Manual}). Under the hood,
+daemon listening on port 2222 (@pxref{Networking Services,
+@code{lsh-service}}). Under the hood,
@code{lsh-service} arranges so that @code{lshd} is started with the
right command-line options, possibly with supporting configuration files
-generated as needed (@pxref{Defining Services}). @xref{operating-system
-Reference}, for details about the available @code{operating-system}
-fields.
+generated as needed (@pxref{Defining Services}).
+
+@cindex customization, of services
+@findex modify-services
+Occasionally, instead of using the base services as is, you will want to
+customize them. For instance, to change the configuration of
+@code{guix-daemon} and Mingetty (the console log-in), you may write the
+following instead of @var{%base-services}:
+
+@lisp
+(modify-services %base-services
+ (guix-service-type config =>
+ (guix-configuration
+ (inherit config)
+ (use-substitutes? #f)
+ (extra-options '("--gc-keep-outputs"))))
+ (mingetty-service-type config =>
+ (mingetty-configuration
+ (inherit config)
+ (motd (plain-file "motd" "Hi there!")))))
+@end lisp
+
+@noindent
+The effect here is to change the options passed to @command{guix-daemon}
+when it is started, as well as the ``message of the day'' that appears
+when logging in at the console. @xref{Service Reference,
+@code{modify-services}}, for more on that.
The configuration for a typical ``desktop'' usage, with the X11 display
-server, a desktop environment, network management, an SSH server, and
+server, a desktop environment, network management, power management, and
more, would look like this:
@lisp
@@ -5310,13 +5427,30 @@ more, would look like this:
@xref{Desktop Services}, for the exact list of services provided by
@var{%desktop-services}. @xref{X.509 Certificates}, for background
information about the @code{nss-certs} package that is used here.
+@xref{operating-system Reference}, for details about all the available
+@code{operating-system} fields.
Assuming the above snippet is stored in the @file{my-system-config.scm}
file, the @command{guix system reconfigure my-system-config.scm} command
instantiates that configuration, and makes it the default GRUB boot
-entry (@pxref{Invoking guix system}). The normal way to change the
-system's configuration is by updating this file and re-running the
-@command{guix system} command.
+entry (@pxref{Invoking guix system}).
+
+The normal way to change the system's configuration is by updating this
+file and re-running @command{guix system reconfigure}. One should never
+have to touch files in @command{/etc} or to run commands that modify the
+system state such as @command{useradd} or @command{grub-install}. In
+fact, you must avoid that since that would not only void your warranty
+but also prevent you from rolling back to previous versions of your
+system, should you ever need to.
+
+@cindex roll-back, of the operating system
+Speaking of roll-back, each time you run @command{guix system
+reconfigure}, a new @dfn{generation} of the system is created---without
+modifying or deleting previous generations. Old system generations get
+an entry in the GRUB boot menu, allowing you to boot them in case
+something went wrong with the latest generation. Reassuring, no? The
+@command{guix system list-generations} command lists the system
+generations available on disk.
At the Scheme level, the bulk of an @code{operating-system} declaration
is instantiated with the following monadic procedure (@pxref{The Store
@@ -6130,6 +6264,9 @@ Whether to authorize the substitute key for @code{hydra.gnu.org}
@item @code{use-substitutes?} (default: @code{#t})
Whether to use substitutes.
+@item @code{substitute-urls} (default: @var{%default-substitute-urls})
+The list of URLs where to look for substitutes by default.
+
@item @code{extra-options} (default: @code{'()})
List of extra command-line options for @command{guix-daemon}.
@@ -6379,6 +6516,19 @@ Last, @var{extra-config} is a list of strings or objects appended to the
verbatim to the configuration file.
@end deffn
+@deffn {Scheme Procedure} screen-locker-service @var{package} [@var{name}]
+Add @var{package}, a package for a screen-locker or screen-saver whose
+command is @var{program}, to the set of setuid programs and add a PAM entry
+for it. For example:
+
+@lisp
+(screen-locker-service xlockmore "xlock")
+@end lisp
+
+makes the good ol' XlockMore usable.
+@end deffn
+
+
@node Desktop Services
@subsubsection Desktop Services
@@ -6396,7 +6546,8 @@ This is a list of services that builds upon @var{%base-services} and
adds or adjust services for a typical ``desktop'' setup.
In particular, it adds a graphical login manager (@pxref{X Window,
-@code{slim-service}}), a network management tool (@pxref{Networking
+@code{slim-service}}), screen lockers,
+a network management tool (@pxref{Networking
Services, @code{wicd-service}}), energy and color management services,
the @code{elogind} login and seat manager, the Polkit privilege service,
the GeoClue location service, an NTP client (@pxref{Networking
@@ -7022,7 +7173,7 @@ supported:
@item reconfigure
Build the operating system described in @var{file}, activate it, and
switch to it@footnote{This action is usable only on systems already
-running GNU.}.
+running GuixSD.}.
This effects all the configuration specified in @var{file}: user
accounts, system services, global package list, setuid programs, etc.
@@ -7064,6 +7215,7 @@ This command also installs GRUB on the device specified in
@item vm
@cindex virtual machine
@cindex VM
+@anchor{guix system vm}
Build a virtual machine that contain the operating system declared in
@var{file}, and return a script to run that virtual machine (VM).
Arguments given to the script are passed as is to QEMU.
@@ -7162,6 +7314,30 @@ KVM kernel module should be loaded, and the @file{/dev/kvm} device node
must exist and be readable and writable by the user and by the daemon's
build users.
+Once you have built, configured, re-configured, and re-re-configured
+your GuixSD installation, you may find it useful to list the operating
+system generations available on disk---and that you can choose from the
+GRUB boot menu:
+
+@table @code
+
+@item list-generations
+List a summary of each generation of the operating system available on
+disk, in a human-readable way. This is similar to the
+@option{--list-generations} option of @command{guix package}
+(@pxref{Invoking guix package}).
+
+Optionally, one can specify a pattern, with the same syntax that is used
+in @command{guix package --list-generations}, to restrict the list of
+generations displayed. For instance, the following command displays
+generations up to 10-day old:
+
+@example
+$ guix system list-generations 10d
+@end example
+
+@end table
+
The @command{guix system} command has even more to offer! The following
sub-commands allow you to visualize how your system services relate to
each other:
@@ -7424,6 +7600,41 @@ Here is an example of how a service is created and manipulated:
@result{} #t
@end example
+The @code{modify-services} form provides a handy way to change the
+parameters of some of the services of a list such as
+@var{%base-services} (@pxref{Base Services, @code{%base-services}}). Of
+course, you could always use standard list combinators such as
+@code{map} and @code{fold} to do that (@pxref{SRFI-1, List Library,,
+guile, GNU Guile Reference Manual}); @code{modify-services} simply
+provides a more concise form for this common pattern.
+
+@deffn {Scheme Syntax} modify-services @var{services} @
+ (@var{type} @var{variable} => @var{body}) @dots{}
+
+Modify the services listed in @var{services} according to the given
+clauses. Each clause has the form:
+
+@example
+(@var{type} @var{variable} => @var{body})
+@end example
+
+where @var{type} is a service type, such as @var{guix-service-type}, and
+@var{variable} is an identifier that is bound within @var{body} to the
+value of the service of that @var{type}. @xref{Using the Configuration
+System}, for an example.
+
+This is a shorthand for:
+
+@example
+(map (lambda (service) @dots{}) @var{services})
+@end example
+@end deffn
+
+Next comes the programming interface for service types. This is
+something you want to know when writing new service definitions, but not
+necessarily when simply looking for ways to customize your
+@code{operating-system} declaration.
+
@deftp {Data Type} service-type
@cindex service type
This is the representation of a @dfn{service type} (@pxref{Service Types
@@ -8245,7 +8456,8 @@ reason.
@node Acknowledgments
@chapter Acknowledgments
-Guix is based on the Nix package manager, which was designed and
+Guix is based on the @uref{http://nixos.org/nix/, Nix package manager},
+which was designed and
implemented by Eelco Dolstra, with contributions from other people (see
the @file{nix/AUTHORS} file in Guix.) Nix pioneered functional package
management, and promoted unprecedented features, such as transactional
diff --git a/emacs/guix-base.el b/emacs/guix-base.el
index e64e375e33..2e99c545f0 100644
--- a/emacs/guix-base.el
+++ b/emacs/guix-base.el
@@ -1035,7 +1035,7 @@ Each element from GENERATIONS is a generation number."
profile generation)))
(guix-eval-in-repl
(guix-make-guile-expression
- 'switch-to-generation profile generation)
+ 'switch-to-generation* profile generation)
operation-buffer)))
(defun guix-package-source-path (package-id)
diff --git a/emacs/guix-command.el b/emacs/guix-command.el
index 1a42594b68..36ce7bcb09 100644
--- a/emacs/guix-command.el
+++ b/emacs/guix-command.el
@@ -364,8 +364,9 @@ to be modified."
:name "-- " :char ?= :option? t args)))
(let ((command (car commands)))
(cond
- ((member command '("archive" "build" "graph" "edit"
- "environment" "lint" "refresh"))
+ ((member command
+ '("archive" "build" "challenge" "edit" "environment"
+ "graph" "lint" "refresh"))
(argument :doc "Packages" :fun 'guix-read-package-names-string))
((string= command "download")
(argument :doc "URL"))
diff --git a/emacs/guix-devel.el b/emacs/guix-devel.el
index 170ce1ad54..8eb030942c 100644
--- a/emacs/guix-devel.el
+++ b/emacs/guix-devel.el
@@ -198,6 +198,7 @@ to find 'modify-phases' keywords."
"mbegin"
"mlet"
"mlet*"
+ "modify-services"
"munless"
"mwhen"
"run-with-state"
@@ -288,6 +289,7 @@ Each rule should have a form (SYMBOL VALUE). See `put' for details."
(mlet 2)
(mlet* 2)
(modify-phases 1)
+ (modify-services 1)
(munless 1)
(mwhen 1)
(operating-system 0)
diff --git a/emacs/guix-pcomplete.el b/emacs/guix-pcomplete.el
index 4743be59bd..98f8efd1d2 100644
--- a/emacs/guix-pcomplete.el
+++ b/emacs/guix-pcomplete.el
@@ -209,8 +209,8 @@ group - the argument.")
"Complete argument for guix COMMAND."
(cond
((member command
- '("archive" "build" "graph" "edit" "environment"
- "lint" "refresh" "size"))
+ '("archive" "build" "challenge" "edit" "environment"
+ "graph" "lint" "refresh" "size"))
(while t
(pcomplete-here (guix-pcomplete-all-packages))))
(t (pcomplete-here* (pcomplete-entries)))))
diff --git a/gnu-system.am b/gnu-system.am
index 13eede8bf6..0ee4eebeef 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -121,7 +121,6 @@ GNU_SYSTEM_MODULES = \
gnu/packages/gcc.scm \
gnu/packages/gd.scm \
gnu/packages/gdb.scm \
- gnu/packages/gdbm.scm \
gnu/packages/geeqie.scm \
gnu/packages/gettext.scm \
gnu/packages/ghostscript.scm \
@@ -693,6 +692,7 @@ dist_patch_DATA = \
gnu/packages/patches/xf86-video-trident-remove-mibstore.patch \
gnu/packages/patches/xf86-video-vmware-glibc-2.20.patch \
gnu/packages/patches/xfce4-panel-plugins.patch \
+ gnu/packages/patches/xfce4-session-fix-xflock4.patch \
gnu/packages/patches/xfce4-settings-defaults.patch \
gnu/packages/patches/xmodmap-asprintf.patch \
gnu/packages/patches/zathura-plugindir-environment-variable.patch
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index e911494058..556422bc38 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -165,7 +165,7 @@ host user identifiers to map into the user namespace."
"Return the number suitable for the 'flags' argument of 'clone' that
corresponds to the symbols in NAMESPACES."
;; Use the same flags as fork(3) in addition to the namespace flags.
- (apply logior SIGCHLD CLONE_CHILD_CLEARTID CLONE_CHILD_SETTID
+ (apply logior SIGCHLD
(map (match-lambda
('mnt CLONE_NEWNS)
('uts CLONE_NEWUTS)
diff --git a/gnu/packages/algebra.scm b/gnu/packages/algebra.scm
index 2f52f5545c..daa5ddd072 100644
--- a/gnu/packages/algebra.scm
+++ b/gnu/packages/algebra.scm
@@ -26,6 +26,7 @@
#:use-module (gnu packages perl)
#:use-module (gnu packages readline)
#:use-module (gnu packages flex)
+ #:use-module (gnu packages xorg)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix download)
@@ -125,6 +126,7 @@ solve the shortest vector problem.")
"0k1qqagfl6zn7gvwmsqffj6g9yrzqvszwh2mblhmxpjlw1pigfh8"))))
(build-system gnu-build-system)
(inputs `(("gmp" ,gmp)
+ ("libx11" ,libx11)
("perl" ,perl)
("readline" ,readline)))
(arguments
diff --git a/gnu/packages/avahi.scm b/gnu/packages/avahi.scm
index b6eef1a6ad..2d480192af 100644
--- a/gnu/packages/avahi.scm
+++ b/gnu/packages/avahi.scm
@@ -23,7 +23,7 @@
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
- #:use-module (gnu packages gdbm)
+ #:use-module (gnu packages databases)
#:use-module (gnu packages libdaemon)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages glib)
diff --git a/gnu/packages/backup.scm b/gnu/packages/backup.scm
index 84d27c08a6..40cfc4ee14 100644
--- a/gnu/packages/backup.scm
+++ b/gnu/packages/backup.scm
@@ -30,9 +30,12 @@
#:use-module (gnu packages acl)
#:use-module (gnu packages base)
#:use-module (gnu packages compression)
+ #:use-module (gnu packages databases)
#:use-module (gnu packages dejagnu)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnupg)
+ #:use-module (gnu packages gperf)
+ #:use-module (gnu packages guile)
#:use-module (gnu packages linux)
#:use-module (gnu packages mcrypt)
#:use-module (gnu packages nettle)
@@ -147,6 +150,7 @@ backups (called chunks) to allow easy burning to CD/DVD.")
(search-patch "libarchive-fix-lzo-test-case.patch")
(search-patch "libarchive-CVE-2013-0211.patch")))))
(build-system gnu-build-system)
+ ;; TODO: Add -L/path/to/nettle in libarchive.pc.
(inputs
`(("zlib" ,zlib)
("nettle" ,nettle)
@@ -352,3 +356,44 @@ deduplication technique used makes Attic suitable for daily backups since only
changes are stored.")
(home-page "https://attic-backup.org/")
(license license:bsd-3)))
+
+(define-public libchop
+ (package
+ (name "libchop")
+ (version "0.5.2")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://savannah/libchop/libchop-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "0fpdyxww41ba52d98blvnf543xvirq1v9xz1i3x1gm9lzlzpmc2g"))
+ (patches
+ (list (search-patch "diffutils-gets-undeclared.patch")))))
+ (build-system gnu-build-system)
+ (native-inputs
+ `(("guile" ,guile-2.0)
+ ("gperf" ,gperf)
+ ("pkg-config" ,pkg-config)))
+ (inputs
+ `(("guile" ,guile-2.0)
+ ("util-linux" ,util-linux)
+ ("gnutls" ,gnutls)
+ ("tdb" ,tdb)
+ ("bdb" ,bdb)
+ ("gdbm" ,gdbm)
+ ("libgcrypt" ,libgcrypt)
+ ("lzo" ,lzo)
+ ("bzip2" ,bzip2)
+ ("zlib" ,zlib)))
+ (home-page "http://nongnu.org/libchop/")
+ (synopsis "Tools & library for data backup and distributed storage")
+ (description
+ "Libchop is a set of utilities and library for data backup and
+distributed storage. Its main application is @command{chop-backup}, an
+encrypted backup program that supports data integrity checks, versioning,
+distribution among several sites, selective sharing of stored data, adaptive
+compression, and more. The library itself implements storage techniques such
+as content-addressable storage, content hash keys, Merkle trees, similarity
+detection, and lossless compression.")
+ (license license:gpl3+)))
diff --git a/gnu/packages/bioinformatics.scm b/gnu/packages/bioinformatics.scm
index 48edd56854..fdb42562e8 100644
--- a/gnu/packages/bioinformatics.scm
+++ b/gnu/packages/bioinformatics.scm
@@ -805,15 +805,16 @@ time.")
(define-public crossmap
(package
(name "crossmap")
- (version "0.1.6")
+ (version "0.2.1")
(source (origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/crossmap/CrossMap-"
version ".tar.gz"))
(sha256
(base32
- "163hi5gjgij6cndxlvbkp5jjwr0k4wbm9im6d2210278q7k9kpnp"))
- ;; patch has been sent upstream already
+ "07y179f63d7qnzdvkqcziwk9bs3k4zhp81q392fp1hwszjdvy22f"))
+ ;; This patch has been sent upstream already and is available
+ ;; for download from Sourceforge, but it has not been merged.
(patches (list
(search-patch "crossmap-allow-system-pysam.patch")))
(modules '((guix build utils)))
@@ -1838,19 +1839,25 @@ the phenotype as it models the data.")
(license license:asl2.0)))
(define-public pbtranscript-tofu
- (let ((commit "c7bbd5472"))
+ (let ((commit "8f5467fe6"))
(package
(name "pbtranscript-tofu")
- (version (string-append "0.4.1." commit))
+ (version (string-append "2.2.3." commit))
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/PacificBiosciences/cDNA_primer.git")
(commit commit)))
- (file-name (string-append name "-" version ".tar.gz"))
+ (file-name (string-append name "-" version "-checkout"))
(sha256
(base32
- "148xkzi689c49g6fdhckp6mnmj2qhjdf1j4wifm6ja7ij95d7fxx"))))
+ "1lgnpi35ihay42qx0b6yl3kkgra723i413j33kvs0kvs61h82w0f"))
+ (modules '((guix build utils)))
+ (snippet
+ '(begin
+ ;; remove bundled Cython sources
+ (delete-file "pbtranscript-tofu/pbtranscript/Cython-0.20.1.tar.gz")
+ #t))))
(build-system python-build-system)
(arguments
`(#:python ,python-2
@@ -1860,34 +1867,29 @@ the phenotype as it models the data.")
#:configure-flags '("--single-version-externally-managed"
"--record=pbtranscript-tofu.txt")
#:phases
- (alist-cons-after
- 'unpack 'enter-directory-and-clean-up
- (lambda _
- (chdir "pbtranscript-tofu/pbtranscript/")
- ;; Delete clutter
- (delete-file-recursively "dist/")
- (delete-file-recursively "build/")
- (delete-file-recursively "setuptools_cython-0.2.1-py2.6.egg/")
- (delete-file-recursively "pbtools.pbtranscript.egg-info")
- (delete-file "Cython-0.20.1.tar.gz")
- (delete-file "setuptools_cython-0.2.1-py2.7.egg")
- (delete-file "setuptools_cython-0.2.1.tar.gz")
- (delete-file "setup.cfg")
- (for-each delete-file
- (find-files "." "\\.so$"))
- ;; files should be writable for install phase
- (for-each (lambda (f) (chmod f #o755))
- (find-files "." "\\.py$")))
- %standard-phases)))
+ (modify-phases %standard-phases
+ (add-after 'unpack 'enter-directory
+ (lambda _
+ (chdir "pbtranscript-tofu/pbtranscript/")
+ #t))
+ ;; With setuptools version 18.0 and later this setup.py hack causes
+ ;; a build error, so we disable it.
+ (add-after 'enter-directory 'patch-setuppy
+ (lambda _
+ (substitute* "setup.py"
+ (("if 'setuptools.extension' in sys.modules:")
+ "if False:"))
+ #t)))))
(inputs
- `(("python-cython" ,python2-cython)
- ("python-numpy" ,python2-numpy)
+ `(("python-numpy" ,python2-numpy)
("python-bx-python" ,python2-bx-python)
("python-networkx" ,python2-networkx)
("python-scipy" ,python2-scipy)
- ("python-pbcore" ,python2-pbcore)))
+ ("python-pbcore" ,python2-pbcore)
+ ("python-h5py" ,python2-h5py)))
(native-inputs
- `(("python-nose" ,python2-nose)
+ `(("python-cython" ,python2-cython)
+ ("python-nose" ,python2-nose)
("python-setuptools" ,python2-setuptools)))
(home-page "https://github.com/PacificBiosciences/cDNA_primer")
(synopsis "Analyze transcriptome data generated with the Iso-Seq protocol")
@@ -2703,7 +2705,24 @@ sequences.")
(build-system gnu-build-system)
(arguments
`(#:tests? #f ;no "check" target
- #:make-flags '("-f" "Makefile.Linux")
+ ;; The CC and CCFLAGS variables are set to contain a lot of x86_64
+ ;; optimizations by default, so we override these flags such that x86_64
+ ;; flags are only added when the build target is an x86_64 system.
+ #:make-flags
+ (list (let ((system ,(or (%current-target-system)
+ (%current-system)))
+ (flags '("-ggdb" "-fomit-frame-pointer"
+ "-ffast-math" "-funroll-loops"
+ "-fmessage-length=0"
+ "-O9" "-Wall" "-DMAKE_FOR_EXON"
+ "-DMAKE_STANDALONE"
+ "-DSUBREAD_VERSION=\\\"${SUBREAD_VERSION}\\\""))
+ (flags64 '("-mmmx" "-msse" "-msse2" "-msse3")))
+ (if (string-prefix? "x86_64" system)
+ (string-append "CCFLAGS=" (string-join (append flags flags64)))
+ (string-append "CCFLAGS=" (string-join flags))))
+ "-f" "Makefile.Linux"
+ "CC=gcc ${CCFLAGS}")
#:phases
(alist-cons-after
'unpack 'enter-dir
diff --git a/gnu/packages/cyrus-sasl.scm b/gnu/packages/cyrus-sasl.scm
index cd0f1bb401..8f3e1a1b70 100644
--- a/gnu/packages/cyrus-sasl.scm
+++ b/gnu/packages/cyrus-sasl.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;;
;;; This file is part of GNU Guix.
@@ -19,7 +19,7 @@
(define-module (gnu packages cyrus-sasl)
#:use-module (gnu packages)
- #:use-module (gnu packages gdbm)
+ #:use-module (gnu packages databases)
#:use-module (gnu packages mit-krb5)
#:use-module (gnu packages tls)
#:use-module ((guix licenses) #:prefix license:)
diff --git a/gnu/packages/databases.scm b/gnu/packages/databases.scm
index a17424196a..51e2a3e058 100644
--- a/gnu/packages/databases.scm
+++ b/gnu/packages/databases.scm
@@ -53,6 +53,28 @@
#:use-module (srfi srfi-26)
#:use-module (ice-9 match))
+(define-public gdbm
+ (package
+ (name "gdbm")
+ (version "1.11")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://gnu/gdbm/gdbm-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "1hz3jgh3pd4qzp6jy0l8pd8x01g9abw7csnrlnj1a2sxy122z4cd"))))
+ (arguments `(#:configure-flags '("--enable-libgdbm-compat")))
+ (build-system gnu-build-system)
+ (home-page "http://www.gnu.org/software/gdbm/")
+ (synopsis
+ "Hash library of database functions compatible with traditional dbm")
+ (description
+ "GDBM is a library for manipulating hashed databases. It is used to
+store key/value pairs in a file in a manner similar to the Unix dbm library
+and provides interfaces to the traditional file format.")
+ (license gpl3+)))
+
(define-public bdb
(package
(name "bdb")
diff --git a/gnu/packages/emacs.scm b/gnu/packages/emacs.scm
index 6416b00ee0..f8be743ce5 100644
--- a/gnu/packages/emacs.scm
+++ b/gnu/packages/emacs.scm
@@ -316,7 +316,7 @@ configuration files, such as .gitattributes, .gitignore, and .git/config.")
(define-public magit
(package
(name "magit")
- (version "2.2.2")
+ (version "2.3.0")
(source (origin
(method url-fetch)
(uri (string-append
@@ -324,7 +324,7 @@ configuration files, such as .gitattributes, .gitignore, and .git/config.")
version "/" name "-" version ".tar.gz"))
(sha256
(base32
- "1imkj4prprnivhbpdn1mdpiryxkckzy5hbnqaahv7gixwac1irh8"))))
+ "0bi0vqp9802f00vnii3x80iqycji20bw4pjysy6al0d86mkggjx5"))))
(build-system gnu-build-system)
(native-inputs `(("texinfo" ,texinfo)
("emacs" ,emacs-no-x)))
@@ -372,7 +372,7 @@ operations.")
(define-public magit-svn
(package
(name "magit-svn")
- (version "2.1.0")
+ (version "2.1.1")
(source (origin
(method url-fetch)
(uri (string-append
@@ -381,7 +381,7 @@ operations.")
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
- "09sz93g7x7g9q75jsw8bdh7yr4jr1igfb4fpg5i302a7l2ahxfr8"))))
+ "04y88j7q9h8xjbx5dbick6n5nr1522sn9i1znp0qwk3vjb4b5mzz"))))
(build-system trivial-build-system)
(native-inputs `(("emacs" ,emacs-no-x)
("tar" ,tar)
diff --git a/gnu/packages/fish.scm b/gnu/packages/fish.scm
index 94e418a8b1..6392efe308 100644
--- a/gnu/packages/fish.scm
+++ b/gnu/packages/fish.scm
@@ -20,6 +20,7 @@
#:use-module (guix licenses)
#:use-module (gnu packages doxygen)
#:use-module (gnu packages ncurses)
+ #:use-module (gnu packages python)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix utils)
@@ -45,7 +46,8 @@
(native-inputs
`(("doxygen" ,doxygen)))
(inputs
- `(("ncurses" ,ncurses)))
+ `(("ncurses" ,ncurses)
+ ("python" ,python-wrapper))) ;for fish_config and manpage completions
(arguments
'(#:tests? #f ; no check target
#:configure-flags '("--sysconfdir=/etc")))
diff --git a/gnu/packages/freeipmi.scm b/gnu/packages/freeipmi.scm
index badecc60ba..6e2610409d 100644
--- a/gnu/packages/freeipmi.scm
+++ b/gnu/packages/freeipmi.scm
@@ -27,14 +27,14 @@
(define-public freeipmi
(package
(name "freeipmi")
- (version "1.4.10")
+ (version "1.4.11")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/freeipmi/freeipmi-"
version ".tar.gz"))
(sha256
(base32
- "1l98l8g8lha85q1d288wr7dyx00x36smh9g5wza15n4wm35c9wqs"))))
+ "0bkghpbj1zkxcgmx2crg0mf97y6dhnxdqvdk5mkw1pyqdxncwq3l"))))
(build-system gnu-build-system)
(inputs
`(("readline" ,readline) ("libgcrypt" ,libgcrypt)))
diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm
index 7e4f18b887..419e2c9cbf 100644
--- a/gnu/packages/gcc.scm
+++ b/gnu/packages/gcc.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
-;;; Copyright © 2014 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2014, 2015 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015 Andreas Enge <andreas@enge.fr>
;;;
;;; This file is part of GNU Guix.
@@ -27,6 +27,7 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages texinfo)
+ #:use-module (gnu packages dejagnu)
#:use-module (gnu packages doxygen)
#:use-module (gnu packages xml)
#:use-module (gnu packages docbook)
@@ -460,6 +461,9 @@ using compilers other than GCC."
("javac.in" ,javac.in)
("ecj-bootstrap" ,ecj-bootstrap)
,@(package-inputs gcc)))
+ (native-inputs
+ `(("dejagnu" ,dejagnu)
+ ,@(package-native-inputs gcc)))
;; Suppress the separate "lib" output, because otherwise the
;; "lib" and "out" outputs would refer to each other, creating
;; a cyclic dependency. <http://debbugs.gnu.org/18101>
@@ -471,7 +475,9 @@ using compilers other than GCC."
(ice-9 regex)
(srfi srfi-1)
(srfi srfi-26))
- ,@(package-arguments gcc))
+ #:test-target "check-target-libjava"
+ ,@(package-arguments gcc))
+ ((#:tests? _) #t)
((#:configure-flags flags)
`(let ((ecj (assoc-ref %build-inputs "ecj-bootstrap")))
`("--enable-java-home"
diff --git a/gnu/packages/gdbm.scm b/gnu/packages/gdbm.scm
deleted file mode 100644
index 62d02001c8..0000000000
--- a/gnu/packages/gdbm.scm
+++ /dev/null
@@ -1,46 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 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 packages gdbm)
- #:use-module (guix licenses)
- #:use-module (guix packages)
- #:use-module (guix download)
- #:use-module (guix build-system gnu))
-
-(define-public gdbm
- (package
- (name "gdbm")
- (version "1.11")
- (source
- (origin
- (method url-fetch)
- (uri (string-append "mirror://gnu/gdbm/gdbm-"
- version ".tar.gz"))
- (sha256
- (base32
- "1hz3jgh3pd4qzp6jy0l8pd8x01g9abw7csnrlnj1a2sxy122z4cd"))))
- (arguments `(#:configure-flags '("--enable-libgdbm-compat")))
- (build-system gnu-build-system)
- (home-page "http://www.gnu.org/software/gdbm/")
- (synopsis
- "Hash library of database functions compatible with traditional dbm")
- (description
- "GDBM is a library for manipulating hashed databases. It is used to
-store key/value pairs in a file in a manner similar to the Unix dbm library
-and provides interfaces to the traditional file format.")
- (license gpl3+)))
diff --git a/gnu/packages/grub.scm b/gnu/packages/grub.scm
index b1da394835..7875a64186 100644
--- a/gnu/packages/grub.scm
+++ b/gnu/packages/grub.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,6 +29,8 @@
#:use-module (gnu packages fontutils)
#:use-module (gnu packages linux)
#:use-module (gnu packages qemu)
+ #:use-module (gnu packages man)
+ #:use-module (gnu packages texinfo)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages cdrom)
#:use-module (srfi srfi-1))
@@ -84,30 +87,35 @@
(build-system gnu-build-system)
(arguments
'(#:configure-flags '("--disable-werror")
- #:phases (alist-cons-before
- 'patch-source-shebangs 'patch-stuff
- (lambda* (#:key inputs #:allow-other-keys)
- (substitute* "grub-core/Makefile.in"
- (("/bin/sh") (which "sh")))
+ #:phases (modify-phases %standard-phases
+ (add-after
+ 'unpack 'patch-stuff
+ (lambda* (#:key inputs #:allow-other-keys)
+ (substitute* "grub-core/Makefile.in"
+ (("/bin/sh") (which "sh")))
- ;; Make the font visible.
- (copy-file (assoc-ref inputs "unifont") "unifont.bdf.gz")
- (system* "gunzip" "unifont.bdf.gz")
+ ;; Make the font visible.
+ (copy-file (assoc-ref inputs "unifont") "unifont.bdf.gz")
+ (system* "gunzip" "unifont.bdf.gz")
- ;; TODO: Re-enable this test when we have Parted.
- (substitute* "tests/partmap_test.in"
- (("set -e") "exit 77")))
- %standard-phases)))
+ ;; TODO: Re-enable this test when we have Parted.
+ (substitute* "tests/partmap_test.in"
+ (("set -e") "exit 77"))
+
+ #t)))))
(inputs
`(;; ("lvm2" ,lvm2)
("gettext" ,gnu-gettext)
("freetype" ,freetype)
;; ("libusb" ,libusb)
+ ;; ("fuse" ,fuse)
("ncurses" ,ncurses)))
(native-inputs
`(("unifont" ,unifont)
("bison" ,bison)
("flex" ,flex)
+ ("texinfo" ,texinfo)
+ ("help2man" ,help2man)
;; Dependencies for the test suite. The "real" QEMU is needed here,
;; because several targets are used.
diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm
index e778bf0f6e..ac9e9c7b42 100644
--- a/gnu/packages/guile.scm
+++ b/gnu/packages/guile.scm
@@ -38,7 +38,7 @@
#:use-module (gnu packages base)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages gettext)
- #:use-module (gnu packages gdbm)
+ #:use-module (gnu packages databases)
#:use-module (gnu packages python)
#:use-module (guix packages)
#:use-module (guix download)
@@ -189,15 +189,15 @@ without requiring the source code to be rewritten.")
(define-public guile-next
(package (inherit guile-2.0)
(name "guile-next")
- (version "20150815.00884bb")
+ (version "20151025.e5bccb6")
(source (origin
(method git-fetch)
(uri (git-reference
(url "git://git.sv.gnu.org/guile.git")
- (commit "00884bb79fff41fdf5f22f24a74e366a94a14c9b")))
+ (commit "e5bccb6e5df3485152bc6501e1f36275e09c6352")))
(sha256
(base32
- "0qk8m9aq3i7pzw6npim58xmsvjqfz5kl1pkyb6b43awn2vydydi5"))))
+ "0z7ywryfcargrpz8hdrz6sfs06c2h2y9baqin3mbjvvg96a5bx47"))))
(arguments
(substitute-keyword-arguments `(;; Tests aren't passing for now.
diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm
index 83ec3f9ca3..b9387f8d43 100644
--- a/gnu/packages/haskell.scm
+++ b/gnu/packages/haskell.scm
@@ -865,14 +865,6 @@ OpenAL.")
(base32
"1sa3zx3vrs1gbinxx33zwq0x2bsf3i964bff7419p7vzidn36k46"))))
(build-system haskell-build-system)
- (arguments
- `(#:phases
- (modify-phases %standard-phases
- (add-after
- 'unpack 'fix-/bin/sh
- (lambda _
- ;; Use `sh', not `/bin/sh'.
- (setenv "CONFIG_SHELL" "sh"))))))
(inputs
`(("sdl" ,sdl)))
(home-page "https://hackage.haskell.org/package/SDL")
@@ -903,14 +895,7 @@ award winning Linux port of \"Civilization: Call To Power.\"")
`(#:configure-flags
(let* ((sdl-mixer (assoc-ref %build-inputs "sdl-mixer"))
(sdl-mixer-include (string-append sdl-mixer "/include/SDL")))
- (list (string-append "--extra-include-dirs=" sdl-mixer-include)))
- #:phases
- (modify-phases %standard-phases
- (add-after
- 'unpack 'fix-/bin/sh
- (lambda _
- ;; Use `sh', not `/bin/sh'.
- (setenv "CONFIG_SHELL" "sh"))))))
+ (list (string-append "--extra-include-dirs=" sdl-mixer-include)))))
(propagated-inputs
`(("ghc-sdl" ,ghc-sdl)))
(inputs
@@ -942,14 +927,7 @@ MIDI, Ogg Vorbis, and SMPEG MP3 libraries.")
`(#:configure-flags
(let* ((sdl-image (assoc-ref %build-inputs "sdl-image"))
(sdl-image-include (string-append sdl-image "/include/SDL")))
- (list (string-append "--extra-include-dirs=" sdl-image-include)))
- #:phases
- (modify-phases %standard-phases
- (add-after
- 'unpack 'fix-/bin/sh
- (lambda _
- ;; Use `sh', not `/bin/sh'.
- (setenv "CONFIG_SHELL" "sh"))))))
+ (list (string-append "--extra-include-dirs=" sdl-image-include)))))
(propagated-inputs
`(("ghc-sdl" ,ghc-sdl)))
(inputs
@@ -1031,10 +1009,10 @@ found at runtime, a userError is thrown.")
(build-system haskell-build-system)
(propagated-inputs
`(("ghc-statevar" ,ghc-statevar)
- ("ghc-openglraw" ,ghc-openglraw)))
- (inputs
- `(("ghc-opengl" ,ghc-opengl)
+ ("ghc-openglraw" ,ghc-openglraw)
("freeglut" ,freeglut)))
+ (inputs
+ `(("ghc-opengl" ,ghc-opengl)))
(home-page "http://www.haskell.org/haskellwiki/Opengl")
(synopsis "Haskell bindings for the OpenGL Utility Toolkit")
(description "This library provides Haskell bindings for the OpenGL
@@ -1216,12 +1194,6 @@ date and time formats.")
(base32
"1h9b26s3kfh2k0ih4383w90ibji6n0iwamxp6rfp2lbq1y5ibjqw"))))
(build-system haskell-build-system)
- (arguments
- `(#:phases
- (modify-phases %standard-phases
- (add-after 'unpack 'fix-/bin/sh
- (lambda _
- (setenv "CONFIG_SHELL" "sh"))))))
(propagated-inputs
`(("ghc-old-locale" ,ghc-old-locale)))
(home-page "http://hackage.haskell.org/package/old-time")
@@ -1433,12 +1405,6 @@ environment variables.")
"X11-" version ".tar.gz"))
(sha256
(base32 "1kzjcynm3rr83ihqx2y2d852jc49da4p18gv6jzm7g87z22x85jj"))))
- (arguments
- `(#:phases (modify-phases %standard-phases
- (add-before 'configure 'set-sh
- (lambda _
- (setenv "CONFIG_SHELL" "sh")
- #t)))))
(build-system haskell-build-system)
(inputs
`(("libx11" ,libx11)
@@ -1801,13 +1767,8 @@ but also need those types.")
"0dyvyxwaffb94bgri1wc4b9wqaasy32pyjn0lww3dqblxv8fn5ax"))))
(build-system haskell-build-system)
(arguments
- `(#:tests? #f ; FIXME: Test fails with "System.Time not found". This is
- ; weird, that should be provided by GHC 7.10.2.
- #:phases
- (modify-phases %standard-phases
- (add-after 'unpack 'fix-/bin/sh
- (lambda _
- (setenv "CONFIG_SHELL" "sh"))))))
+ `(#:tests? #f)) ; FIXME: Test fails with "System.Time not found". This
+ ; is weird, that should be provided by GHC 7.10.2.
(propagated-inputs
`(("ghc-old-time" ,ghc-old-time)
("ghc-old-locale" ,ghc-old-locale)))
@@ -3162,11 +3123,7 @@ boxed and storable vectors.")
(inputs
`(("ghc-hunit" ,ghc-hunit)))
(arguments
- `(#:tests? #f ; FIXME: currently missing libraries used for tests.
- #:phases
- (modify-phases %standard-phases
- (add-before 'configure 'set-sh
- (lambda _ (setenv "CONFIG_SHELL" "sh"))))))
+ `(#:tests? #f)) ; FIXME: currently missing libraries used for tests.
(home-page "https://github.com/haskell/network")
(synopsis "Low-level networking interface")
(description
@@ -3645,7 +3602,7 @@ library for Haskell.")
(home-page "https://github.com/simonmar/async")
(synopsis "Library to run IO operations asynchronously")
(description "Async provides a library to run IO operations
-asynchronously, and wait for their results. It is a higher-level interface
+asynchronously, and wait for their results. It is a higher-level interface
over threads in Haskell, in which @code{Async a} is a concurrent thread that
will eventually deliver a value of type @code{a}.")
(license bsd-3)))
diff --git a/gnu/packages/java.scm b/gnu/packages/java.scm
index 5fa546a98c..6d3446055a 100644
--- a/gnu/packages/java.scm
+++ b/gnu/packages/java.scm
@@ -576,7 +576,7 @@ build process and its dependencies, whereas Make uses Makefile format.")
(license license:gpl2+)))
(define-public icedtea7
- (let* ((version "2.6.1")
+ (let* ((version "2.6.2")
(drop (lambda (name hash)
(origin
(method url-fetch)
@@ -594,7 +594,7 @@ build process and its dependencies, whereas Make uses Makefile format.")
version ".tar.xz"))
(sha256
(base32
- "0s107vi1530a5dyxacysc4m64zshgg2d3xpndsc0ws99wz0zmr6c"))
+ "0xi0w8gpxx3r68hyi7fb991hxb3rqfp7895nfsl4wj3sa1f5ds5y"))
(modules '((guix build utils)))
(snippet
'(substitute* "Makefile.in"
@@ -728,24 +728,24 @@ build process and its dependencies, whereas Make uses Makefile format.")
(native-inputs
`(("openjdk-drop"
,(drop "openjdk"
- "0gs6vbj5c09516r460r68i7vm652sb25h973kq9hfx749qbs0s01"))
+ "0jabxc8iw7ciz6f2qshcpla66qniy686vnxnfx3h2yw7syvas4a9"))
("corba-drop"
,(drop "corba"
- "1y7nf6hqry1az28i3b6ln5cs82cww1jj4r61jk54ab8s2xydj0yd"))
+ "1bw22djg8mfqqn8kp8mpbj9vi4pl8dk67qwwrny67d0fvirixylj"))
("jaxp-drop"
,(drop "jaxp"
- "1szs2w0p496k1qi3yl1fymj0g10lgq31am35zlalcz7pi4l4q360"))
+ "1h3g2dwbj8ihicl73qbr4cvvc3i5bs5ckrpja1nx6g5b56xa7kcl"))
("jaxws-drop"
,(drop "jaxws"
- "17xfy9q2zdpap7m2prbf937x55jm3pwrqpp1fdlridraqrfzjprd"))
+ "1m1h7455qn4pdhb5yamdl9965iz9260lzwl3njcs35vi14v7fihl"))
("jdk-drop"
,(drop "jdk"
- "0qskhwr4nml49zhbppnq8ldj0x001bl37mrcpxslbnsdw5skw258"))
+ "1wcaxf2chnlpk34q04c23im6z32dy8fr6f9giz3ih65nyvah3n3s"))
("langtools-drop"
,(drop "langtools"
- "0hyxrrb0zrx1pq1s90bmim94hwfligr0ajzs1874da4gclbbvfbd"))
+ "0da3cmm8nwz7dk2sqnywvidaa0kjnyzzi33p2lkdi4415f8yhgx5"))
("hotspot-drop"
,(drop "hotspot"
- "1cv8df2s89mnjzg4rja4i89d4fr8n0c3v5y2cqbww1ma1463n100"))
+ "0fn3cjhqsgbkfzychkvvw6whxil2n9dr6q0196ywxzkinny1hjcq"))
,@(fold alist-delete (package-native-inputs icedtea6)
'("openjdk6-src")))))))
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index ecb0fd090b..aa2fc0283b 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -210,7 +210,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM."
#f)))
(define-public linux-libre
- (let* ((version "4.2.4")
+ (let* ((version "4.2.5")
(build-phase
'(lambda* (#:key system inputs #:allow-other-keys #:rest args)
;; Apply the neat patch.
@@ -220,6 +220,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM."
(let ((arch (car (string-split system #\-))))
(setenv "ARCH"
(cond ((string=? arch "i686") "i386")
+ ((string=? arch "mips64el") "mips")
(else arch)))
(format #t "`ARCH' set to `~a'~%" (getenv "ARCH")))
@@ -266,7 +267,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM."
(for-each (lambda (file)
(copy-file file
(string-append out "/" (basename file))))
- (find-files "." "^(bzImage|System\\.map)$"))
+ (find-files "." "^(bzImage|vmlinuz|System\\.map)$"))
(copy-file ".config" (string-append out "/config"))
(zero? (system* "make"
(string-append "DEPMOD=" mit "/sbin/depmod")
@@ -283,8 +284,9 @@ for SYSTEM, or #f if there is no configuration for SYSTEM."
(uri (linux-libre-urls version))
(sha256
(base32
- "11r9yhi4c2zwfb8i21zk014gcm1kvnabq410wjy6g6a015d5v37w"))))
+ "13ar9sghm2g5w2km9x2d07q3lh81rz286d6slklv56qanm24chzx"))))
(build-system gnu-build-system)
+ (supported-systems '("x86_64-linux" "i686-linux"))
(native-inputs `(("perl" ,perl)
("bc" ,bc)
("module-init-tools" ,module-init-tools)
diff --git a/gnu/packages/mail.scm b/gnu/packages/mail.scm
index 9a597e2a4e..1a0a42d267 100644
--- a/gnu/packages/mail.scm
+++ b/gnu/packages/mail.scm
@@ -36,7 +36,6 @@
#:use-module (gnu packages dejagnu)
#:use-module (gnu packages emacs)
#:use-module (gnu packages enchant)
- #:use-module (gnu packages gdbm)
#:use-module (gnu packages ghostscript)
#:use-module (gnu packages glib)
#:use-module (gnu packages gnome)
@@ -48,7 +47,6 @@
#:use-module (gnu packages libidn)
#:use-module (gnu packages linux)
#:use-module (gnu packages m4)
- #:use-module (gnu packages databases)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages pcre)
#:use-module (gnu packages perl)
diff --git a/gnu/packages/man.scm b/gnu/packages/man.scm
index 46b7d8b9b0..3298268d28 100644
--- a/gnu/packages/man.scm
+++ b/gnu/packages/man.scm
@@ -24,9 +24,9 @@
#:use-module (guix download)
#:use-module (guix packages)
#:use-module (guix build-system gnu)
+ #:use-module (gnu packages databases)
#:use-module (gnu packages flex)
#:use-module (gnu packages gawk)
- #:use-module (gnu packages gdbm)
#:use-module (gnu packages groff)
#:use-module (gnu packages less)
#:use-module (gnu packages lynx)
diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm
index 5fa37d1535..4935f8019f 100644
--- a/gnu/packages/maths.scm
+++ b/gnu/packages/maths.scm
@@ -1461,7 +1461,7 @@ constant parts of it.")
(define-public openblas
(package
(name "openblas")
- (version "0.2.14")
+ (version "0.2.15")
(source
(origin
(method url-fetch)
@@ -1470,7 +1470,7 @@ constant parts of it.")
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
- "0av3pd96j8rx5i65f652xv9wqfkaqn0w4ma1gvbyz73i6j2hi9db"))))
+ "1k5f6vjlk54qlplk5m7xkbaw6g2y7dl50lwwdv6xsbcsgsbxfcpy"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ;no "check" target
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index 8fbe5b3064..65464f7691 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -23,9 +23,12 @@
#:use-module (guix git-download)
#:use-module (guix utils)
#:use-module (guix build-system gnu)
- #:use-module ((guix licenses) #:select (gpl2+ gpl3+ lgpl2.1+))
+ #:use-module (guix build-system python)
+ #:use-module ((guix licenses) #:select (gpl2+ gpl3+ lgpl2.1+ asl2.0))
#:use-module (gnu packages)
#:use-module (gnu packages guile)
+ #:use-module (gnu packages file)
+ #:use-module (gnu packages backup)
#:use-module (gnu packages compression)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages databases)
@@ -34,12 +37,17 @@
#:use-module (gnu packages autotools)
#:use-module (gnu packages gettext)
#:use-module (gnu packages texinfo)
+ #:use-module (gnu packages nettle)
#:use-module (gnu packages perl)
#:use-module (gnu packages curl)
#:use-module (gnu packages web)
#:use-module (gnu packages man)
#:use-module (gnu packages emacs)
#:use-module (gnu packages bdw-gc)
+ #:use-module (gnu packages python)
+ #:use-module (gnu packages popt)
+ #:use-module (gnu packages gnuzilla)
+ #:use-module (gnu packages cpio)
#:use-module (gnu packages tls))
(define (boot-guile-uri arch)
@@ -275,3 +283,130 @@ typically used for managing software packages installed from source, by
letting you install them apart in distinct directories and then create
symlinks to the files in a common directory such as /usr/local.")
(license gpl2+)))
+
+(define-public rpm
+ (package
+ (name "rpm")
+ (version "4.12.0")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "http://rpm.org/releases/rpm-4.12.x/rpm-"
+ version ".tar.bz2"))
+ (sha256
+ (base32
+ "18hk47hc755nslvb7xkq4jb095z7va0nlcyxdpxayc4lmb8mq3bp"))))
+ (build-system gnu-build-system)
+ (arguments
+ '(#:configure-flags '("--with-external-db" ;use the system's bdb
+ "--enable-python"
+ "--without-lua")
+ #:phases (modify-phases %standard-phases
+ (add-before 'configure 'set-nspr-search-path
+ (lambda* (#:key inputs #:allow-other-keys)
+ ;; nspr.pc contains the right -I flag pointing to
+ ;; 'include/nspr', but unfortunately 'configure' doesn't
+ ;; use 'pkg-config'. Thus, augment CPATH.
+ ;; Likewise for NSS.
+ (let ((nspr (assoc-ref inputs "nspr"))
+ (nss (assoc-ref inputs "nss")))
+ (setenv "CPATH"
+ (string-append (getenv "CPATH") ":"
+ nspr "/include/nspr:"
+ nss "/include/nss"))
+ (setenv "LIBRARY_PATH"
+ (string-append (getenv "LIBRARY_PATH") ":"
+ nss "/lib/nss"))
+ #t)))
+ (add-after 'install 'fix-rpm-symlinks
+ (lambda* (#:key outputs #:allow-other-keys)
+ ;; 'make install' gets these symlinks wrong. Fix them.
+ (let* ((out (assoc-ref outputs "out"))
+ (bin (string-append out "/bin")))
+ (with-directory-excursion bin
+ (for-each (lambda (file)
+ (delete-file file)
+ (symlink "rpm" file))
+ '("rpmquery" "rpmverify"))
+ #t)))))))
+ (native-inputs
+ `(("pkg-config" ,pkg-config)))
+ (inputs
+ `(("python" ,python-2)
+ ("xz" ,xz)
+ ("bdb" ,bdb)
+ ("popt" ,popt)
+ ("nss" ,nss)
+ ("nspr" ,nspr)
+ ("libarchive" ,libarchive)
+ ("nettle" ,nettle) ;XXX: actually a dependency of libarchive
+ ("file" ,file)
+ ("bzip2" ,bzip2)
+ ("zlib" ,zlib)
+ ("cpio" ,cpio)))
+ (home-page "http://www.rpm.org/")
+ (synopsis "The RPM Package Manager")
+ (description
+ "The RPM Package Manager (RPM) is a command-line driven package
+management system capable of installing, uninstalling, verifying, querying,
+and updating computer software packages. Each software package consists of an
+archive of files along with information about the package like its version, a
+description. There is also a library permitting developers to manage such
+transactions from C or Python.")
+
+ ;; The whole is GPLv2+; librpm itself is dual-licensed LGPLv2+ | GPLv2+.
+ (license gpl2+)))
+
+(define-public diffoscope
+ (package
+ (name "diffoscope")
+ (version "34")
+ (source (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url
+ "https://anonscm.debian.org/cgit/reproducible/diffoscope.git")
+ (commit version)))
+ (sha256
+ (base32
+ "1g8b7bpkmns0355gkr3a244affwx4xzqwahwsl6ivw4z0qv7dih8"))
+ (file-name (string-append name "-" version "-checkout"))))
+ (build-system python-build-system)
+ (arguments
+ `(#:python ,python-2
+ #:phases (modify-phases %standard-phases
+ (add-before 'build 'disable-egg-zipping
+ (lambda _
+ ;; Leave the .egg file uncompressed.
+ (let ((port (open-file "setup.cfg" "a")))
+ (display "\n[easy_install]\nzip_ok = 0\n"
+ port)
+ (close-port port)
+ #t)))
+ (add-before 'build 'dependency-on-rpm
+ (lambda _
+ (substitute* "setup.py"
+ ;; Somehow this requirement is reported as not met,
+ ;; even though rpm.py is in the search path. So
+ ;; delete it.
+ (("'rpm-python',") ""))
+ #t)))
+ ;; FIXME: Some obscure test failures.
+ #:tests? #f))
+ (inputs `(("rpm" ,rpm) ;for rpm-python
+ ("python-file" ,python2-file)
+ ("python-debian" ,python2-debian)
+ ("python-libarchive-c" ,python2-libarchive-c)
+ ("python-tlsh" ,python2-tlsh)
+
+ ;; Below are modules used for tests.
+ ("python-pytest" ,python2-pytest)
+ ("python-chardet" ,python2-chardet)))
+ (native-inputs `(("python-setuptools" ,python2-setuptools)))
+ (home-page "http://diffoscope.org/")
+ (synopsis "Compare files, archives, and directories in depth")
+ (description
+ "Diffoscope tries to get to the bottom of what makes files or directories
+different. It recursively unpacks archives of many kinds and transforms
+various binary formats into more human readable forms to compare them. It can
+compare two tarballs, ISO images, or PDFs just as easily.")
+ (license gpl3+)))
diff --git a/gnu/packages/password-utils.scm b/gnu/packages/password-utils.scm
index 921ade1030..3cb319aeda 100644
--- a/gnu/packages/password-utils.scm
+++ b/gnu/packages/password-utils.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2015 Aljosha Papsch <misc@rpapsch.de>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -26,6 +27,9 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages guile)
+ #:use-module (gnu packages ncurses)
+ #:use-module (gnu packages pkg-config)
+ #:use-module (gnu packages tls)
#:use-module (gnu packages qt)
#:use-module (gnu packages xdisorg)
#:use-module (gnu packages xorg))
@@ -104,3 +108,31 @@ For copying and pasting secrets into web browsers and other graphical
applications, there is xclip integration." )
(home-page "http://dthompson.us/pages/software/shroud.html")
(license license:gpl3+)))
+
+(define-public yapet
+ (package
+ (name "yapet")
+ (version "1.0")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "http://www.guengel.ch/myapps/yapet/downloads/yapet-"
+ version
+ ".tar.bz2"))
+ (sha256
+ (base32
+ "0ydbnqw6icdh07pnv2w6dhvq501bdfvrklv4xmyr8znca9d753if"))))
+ (build-system gnu-build-system)
+ (inputs
+ `(("ncurses" ,ncurses)
+ ("openssl" ,openssl)))
+ (native-inputs
+ `(("pkg-config" ,pkg-config)))
+ (synopsis "Yet Another Password Encryption Tool")
+ (description "YAPET is a text based password manager using the Blowfish
+encryption algorithm. Because of its small footprint and very few library
+dependencies, it is suited for installing on desktop and server systems alike.
+The text based user interface allows you to run YAPET easily in a Secure Shell
+session. Two companion utilities enable users to convert CSV files to YAPET
+and vice versa.")
+ (home-page "http://www.guengel.ch/myapps/yapet/")
+ (license license:gpl3+)))
diff --git a/gnu/packages/patches/xfce4-session-fix-xflock4.patch b/gnu/packages/patches/xfce4-session-fix-xflock4.patch
new file mode 100644
index 0000000000..74769e4257
--- /dev/null
+++ b/gnu/packages/patches/xfce4-session-fix-xflock4.patch
@@ -0,0 +1,31 @@
+From cbb9c769316b4d32956a2c78aa01a38b473f0cfc Mon Sep 17 00:00:00 2001
+From: David Thompson <dthompson2@worcester.edu>
+Date: Fri, 30 Oct 2015 08:30:43 -0400
+Subject: [PATCH] xflock4: Do not override PATH with hardcoded value.
+
+The PATH "/bin:/usr/bin" may not be a valid search path on the user's
+machine. The screen locking program may be in /usr/local/bin or
+elsewhere. Distros that do not conform to the FHS, such as GuixSD and
+NixOS, will not have their executables in either location. Thus, we
+simply leave PATH alone.
+---
+ scripts/xflock4 | 3 ---
+ 1 file changed, 3 deletions(-)
+
+diff --git a/scripts/xflock4 b/scripts/xflock4
+index ec4d05d..e7981ac 100644
+--- a/scripts/xflock4
++++ b/scripts/xflock4
+@@ -21,9 +21,6 @@
+ # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ #
+
+-PATH=/bin:/usr/bin
+-export PATH
+-
+ # Lock by xscreensaver or gnome-screensaver, if a respective daemon is running
+ for lock_cmd in \
+ "xscreensaver-command -lock" \
+--
+2.5.0
+
diff --git a/gnu/packages/pcre.scm b/gnu/packages/pcre.scm
index d07e434190..d7d974fc5c 100644
--- a/gnu/packages/pcre.scm
+++ b/gnu/packages/pcre.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -57,3 +58,37 @@ own native API, as well as a set of wrapper functions that correspond to the
POSIX regular expression API.")
(license license:bsd-3)
(home-page "http://www.pcre.org/")))
+
+(define-public pcre2
+ (package
+ (name "pcre2")
+ (version "10.20")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://sourceforge/pcre/pcre2/"
+ version "/pcre2-" version ".tar.bz2"))
+
+ (sha256
+ (base32
+ "0yj8mm9ll9zj3v47rvmmqmr1ybxk72rr2lym3rymdsf905qjhbik"))))
+ (build-system gnu-build-system)
+ (inputs `(("bzip2" ,bzip2)
+ ("readline" ,readline)
+ ("zlib" ,zlib)))
+ (arguments
+ `(#:configure-flags '("--enable-unicode"
+ "--enable-pcregrep-libz"
+ "--enable-pcregrep-libbz2"
+ "--enable-pcretest-libreadline"
+ "--enable-unicode-properties"
+ "--enable-pcre2-16"
+ "--enable-pcre2-32"
+ "--enable-jit")))
+ (synopsis "Perl Compatible Regular Expressions")
+ (description
+ "The PCRE library is a set of functions that implement regular expression
+pattern matching using the same syntax and semantics as Perl 5. PCRE has its
+own native API, as well as a set of wrapper functions that correspond to the
+POSIX regular expression API.")
+ (license license:bsd-3)
+ (home-page "http://www.pcre.org/")))
diff --git a/gnu/packages/pulseaudio.scm b/gnu/packages/pulseaudio.scm
index 2c283f0986..fa656b3db6 100644
--- a/gnu/packages/pulseaudio.scm
+++ b/gnu/packages/pulseaudio.scm
@@ -27,7 +27,7 @@
#:use-module (gnu packages autotools)
#:use-module (gnu packages avahi)
#:use-module (gnu packages check)
- #:use-module (gnu packages gdbm)
+ #:use-module (gnu packages databases)
#:use-module (gnu packages glib)
#:use-module (gnu packages gtk)
#:use-module (gnu packages libcanberra)
diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm
index 54d882cb6e..b37bb1360f 100644
--- a/gnu/packages/python.scm
+++ b/gnu/packages/python.scm
@@ -39,8 +39,8 @@
#:use-module (gnu packages backup)
#:use-module (gnu packages compression)
#:use-module (gnu packages databases)
+ #:use-module (gnu packages file)
#:use-module (gnu packages fontutils)
- #:use-module (gnu packages gdbm)
#:use-module (gnu packages gcc)
#:use-module (gnu packages ghostscript)
#:use-module (gnu packages glib)
@@ -5761,3 +5761,98 @@ Python's @code{ctypes} foreign function interface (FFI).")
(define-public python2-libarchive-c
(package-with-python2 python-libarchive-c))
+
+(define-public python-file
+ (package
+ (inherit file)
+ (name "python-file")
+ (build-system python-build-system)
+ (arguments
+ '(#:tests? #f ;no tests
+ #:phases (modify-phases %standard-phases
+ (add-before 'build 'change-directory
+ (lambda _
+ (chdir "python")
+ #t))
+ (add-before 'build 'set-library-file-name
+ (lambda* (#:key inputs #:allow-other-keys)
+ (let ((file (assoc-ref inputs "file")))
+ (substitute* "magic.py"
+ (("find_library\\('magic'\\)")
+ (string-append "'" file "/lib/libmagic.so'")))
+ #t))))))
+ (inputs `(("file" ,file)))
+ (self-native-input? #f)
+ (synopsis "Python bindings to the libmagic file type guesser")))
+
+(define-public python2-file
+ (package-with-python2 python-file))
+
+(define-public python-debian
+ (package
+ (name "python-debian")
+ (version "0.1.23")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append
+ "https://pypi.python.org/packages/source/p/python-debian/python-debian-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "193faznwnjc3n5991wyzim6h9gyq1zxifmfrnpm3avgkh7ahyynh"))))
+ (build-system python-build-system)
+ (inputs
+ `(("python-six" ,python-six)))
+ (native-inputs
+ `(("python-setuptools" ,python-setuptools)))
+ (home-page "http://packages.debian.org/sid/python-debian")
+ (synopsis "Debian package related modules")
+ (description
+ ;; XXX: Use @enumerate instead of @itemize to work around
+ ;; <http://bugs.gnu.org/21772>.
+ "This package provides Python modules that abstract many formats of
+Debian-related files, such as:
+
+@enumerate
+@item Debtags information;
+@item @file{debian/changelog} files;
+@item packages files, pdiffs;
+@item control files of single or multiple RFC822-style paragraphs---e.g.
+ @file{debian/control}, @file{.changes}, @file{.dsc};
+@item Raw @file{.deb} and @file{.ar} files, with (read-only) access to
+ contained files and meta-information.
+@end enumerate\n")
+
+ ;; Modules are either GPLv2+ or GPLv3+.
+ (license gpl3+)))
+
+(define-public python2-debian
+ (package-with-python2 python-debian))
+
+(define-public python-chardet
+ (package
+ (name "python-chardet")
+ (version "2.3.0")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append
+ "https://pypi.python.org/packages/source/c/chardet/chardet-"
+ version
+ ".tar.gz"))
+ (sha256
+ (base32
+ "1ak87ikcw34fivcgiz2xvi938dmclh078az65l9x3rmgljrkhgp5"))))
+ (build-system python-build-system)
+ (native-inputs
+ `(("python-setuptools" ,python-setuptools)))
+ (home-page "https://github.com/chardet/chardet")
+ (synopsis "Universal encoding detector for Python 2 and 3")
+ (description
+ "This package provides @code{chardet}, a Python module that can
+automatically detect a wide range of file encodings.")
+ (license lgpl2.1+)))
+
+(define-public python2-chardet
+ (package-with-python2 python-chardet))
diff --git a/gnu/packages/ruby.scm b/gnu/packages/ruby.scm
index 701b7ee6ef..8bf85233ea 100644
--- a/gnu/packages/ruby.scm
+++ b/gnu/packages/ruby.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 Pjotr Prins <pjotr.guix@thebird.nl>
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014, 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
@@ -30,7 +30,6 @@
#:use-module (gnu packages autotools)
#:use-module (gnu packages java)
#:use-module (gnu packages libffi)
- #:use-module (gnu packages gdbm)
#:use-module (gnu packages tls)
#:use-module (gnu packages version-control)
#:use-module (guix packages)
diff --git a/gnu/packages/sawfish.scm b/gnu/packages/sawfish.scm
index e2cb62c62c..9b09b6171e 100644
--- a/gnu/packages/sawfish.scm
+++ b/gnu/packages/sawfish.scm
@@ -22,7 +22,7 @@
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
- #:use-module (gnu packages gdbm)
+ #:use-module (gnu packages databases)
#:use-module (gnu packages gettext)
#:use-module (gnu packages gtk)
#:use-module (gnu packages libffi)
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 7465b1b58c..aea8b54433 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -334,7 +334,7 @@ implementation techniques and as an expository tool.")
(define-public racket
(package
(name "racket")
- (version "6.1.1")
+ (version "6.2.1")
(source (origin
(method url-fetch)
(uri (list (string-append "http://mirror.racket-lang.org/installers/"
@@ -344,7 +344,7 @@ implementation techniques and as an expository tool.")
version "/racket/racket-" version "-src-unix.tgz")))
(sha256
(base32
- "0xfsfdqkngz0xw2lqmc7bsznwx25cw91l9fjhp7abrr05m96j0h9"))))
+ "0555j63k7fs10iv0icmivlxpzgp6s7gwcbfddmbwxlf2rk80qhq0"))))
(build-system gnu-build-system)
(arguments
'(#:phases
diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm
index a95fe83bbd..773b2ebf99 100644
--- a/gnu/packages/video.scm
+++ b/gnu/packages/video.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;; Copyright © 2015 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2015 Andy Patterson <ajpatter@uwaterloo.ca>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -412,6 +413,89 @@ standards (MPEG-2, MPEG-4 ASP/H.263, MPEG-4 AVC/H.264, and VC-1/VMW3).")
("yasm" ,yasm)))
(arguments
`(#:test-target "fate"
+ #:configure-flags
+ ;; possible additional inputs:
+ ;; --enable-avisynth enable reading of AviSynth script
+ ;; files [no]
+ ;; --enable-frei0r enable frei0r video filtering
+ ;; --enable-libaacplus enable AAC+ encoding via libaacplus [no]
+ ;; --enable-libcelt enable CELT decoding via libcelt [no]
+ ;; --enable-libdc1394 enable IIDC-1394 grabbing using libdc1394
+ ;; and libraw1394 [no]
+ ;; --enable-libfaac enable AAC encoding via libfaac [no]
+ ;; --enable-libfdk-aac enable AAC de/encoding via libfdk-aac [no]
+ ;; --enable-libflite enable flite (voice synthesis) support via
+ ;; libflite [no]
+ ;; --enable-libgme enable Game Music Emu via libgme [no]
+ ;; --enable-libgsm enable GSM de/encoding via libgsm [no]
+ ;; --enable-libiec61883 enable iec61883 via libiec61883 [no]
+ ;; --enable-libilbc enable iLBC de/encoding via libilbc [no]
+ ;; --enable-libmodplug enable ModPlug via libmodplug [no]
+ ;; --enable-libnut enable NUT (de)muxing via libnut,
+ ;; native (de)muxer exists [no]
+ ;; --enable-libopencore-amrnb enable AMR-NB de/encoding via
+ ;; libopencore-amrnb [no]
+ ;; --enable-libopencore-amrwb enable AMR-WB decoding via
+ ;; libopencore-amrwb [no]
+ ;; --enable-libopencv enable video filtering via libopencv [no]
+ ;; --enable-libopenjpeg enable JPEG 2000 de/encoding via
+ ;; OpenJPEG [no]
+ ;; --enable-librtmp enable RTMP[E] support via librtmp [no]
+ ;; --enable-libschroedinger enable Dirac de/encoding via
+ ;; libschroedinger [no]
+ ;; --enable-libshine enable fixed-point MP3 encoding via
+ ;; libshine [no]
+ ;; --enable-libssh enable SFTP protocol via libssh [no]
+ ;; (libssh2 does not work)
+ ;; --enable-libstagefright-h264 enable H.264 decoding via
+ ;; libstagefright [no]
+ ;; --enable-libutvideo enable Ut Video encoding and decoding via
+ ;; libutvideo [no]
+ ;; --enable-libv4l2 enable libv4l2/v4l-utils [no]
+ ;; --enable-libvidstab enable video stabilization using
+ ;; vid.stab [no]
+ ;; --enable-libvo-aacenc enable AAC encoding via libvo-aacenc [no]
+ ;; --enable-libvo-amrwbenc enable AMR-WB encoding via
+ ;; libvo-amrwbenc [no]
+ ;; --enable-libwavpack enable wavpack encoding via libwavpack [no]
+ ;; --enable-libxavs enable AVS encoding via xavs [no]
+ ;; --enable-libzmq enable message passing via libzmq [no]
+ ;; --enable-libzvbi enable teletext support via libzvbi [no]
+ ;; --enable-opencl enable OpenCL code
+ ;; --enable-x11grab enable X11 grabbing [no]
+ '("--enable-avresample"
+ "--enable-gpl" ; enable optional gpl licensed parts
+ "--enable-shared"
+ "--enable-fontconfig"
+ ;; "--enable-gnutls" ; causes test failures
+ "--enable-ladspa"
+ "--enable-libass"
+ "--enable-libbluray"
+ "--enable-libcaca"
+ "--enable-libcdio"
+ "--enable-libfreetype"
+ "--enable-libmp3lame"
+ "--enable-libopus"
+ "--enable-libpulse"
+ "--enable-libquvi"
+ "--enable-libsoxr"
+ "--enable-libspeex"
+ "--enable-libtheora"
+ "--enable-libtwolame"
+ "--enable-libvorbis"
+ "--enable-libvpx"
+ "--enable-libxvid"
+ "--enable-libx264"
+ "--enable-openal"
+
+ "--enable-runtime-cpudetect"
+
+ ;; Runtime cpu detection is not implemented on
+ ;; MIPS, so we disable some features.
+ "--disable-mips32r2"
+ "--disable-mipsdspr1"
+ "--disable-mipsdspr2"
+ "--disable-mipsfpu")
#:phases
(modify-phases %standard-phases
(replace
@@ -424,83 +508,13 @@ standards (MPEG-2, MPEG-4 ASP/H.263, MPEG-4 AVC/H.264, and VC-1/VMW3).")
(("#! /bin/sh") (string-append "#!" (which "bash"))))
(setenv "SHELL" (which "bash"))
(setenv "CONFIG_SHELL" (which "bash"))
- ;; possible additional inputs:
- ;; --enable-avisynth enable reading of AviSynth script files [no]
- ;; --enable-frei0r enable frei0r video filtering
- ;; --enable-libaacplus enable AAC+ encoding via libaacplus [no]
- ;; --enable-libcelt enable CELT decoding via libcelt [no]
- ;; --enable-libdc1394 enable IIDC-1394 grabbing using libdc1394
- ;; and libraw1394 [no]
- ;; --enable-libfaac enable AAC encoding via libfaac [no]
- ;; --enable-libfdk-aac enable AAC de/encoding via libfdk-aac [no]
- ;; --enable-libflite enable flite (voice synthesis) support via libflite [no]
- ;; --enable-libgme enable Game Music Emu via libgme [no]
- ;; --enable-libgsm enable GSM de/encoding via libgsm [no]
- ;; --enable-libiec61883 enable iec61883 via libiec61883 [no]
- ;; --enable-libilbc enable iLBC de/encoding via libilbc [no]
- ;; --enable-libmodplug enable ModPlug via libmodplug [no]
- ;; --enable-libnut enable NUT (de)muxing via libnut,
- ;; native (de)muxer exists [no]
- ;; --enable-libopencore-amrnb enable AMR-NB de/encoding via libopencore-amrnb [no]
- ;; --enable-libopencore-amrwb enable AMR-WB decoding via libopencore-amrwb [no]
- ;; --enable-libopencv enable video filtering via libopencv [no]
- ;; --enable-libopenjpeg enable JPEG 2000 de/encoding via OpenJPEG [no]
- ;; --enable-librtmp enable RTMP[E] support via librtmp [no]
- ;; --enable-libschroedinger enable Dirac de/encoding via libschroedinger [no]
- ;; --enable-libshine enable fixed-point MP3 encoding via libshine [no]
- ;; --enable-libssh enable SFTP protocol via libssh [no]
- ;; (libssh2 does not work)
- ;; --enable-libstagefright-h264 enable H.264 decoding via libstagefright [no]
- ;; --enable-libutvideo enable Ut Video encoding and decoding via libutvideo [no]
- ;; --enable-libv4l2 enable libv4l2/v4l-utils [no]
- ;; --enable-libvidstab enable video stabilization using vid.stab [no]
- ;; --enable-libvo-aacenc enable AAC encoding via libvo-aacenc [no]
- ;; --enable-libvo-amrwbenc enable AMR-WB encoding via libvo-amrwbenc [no]
- ;; --enable-libwavpack enable wavpack encoding via libwavpack [no]
- ;; --enable-libxavs enable AVS encoding via xavs [no]
- ;; --enable-libzmq enable message passing via libzmq [no]
- ;; --enable-libzvbi enable teletext support via libzvbi [no]
- ;; --enable-opencl enable OpenCL code
- ;; --enable-x11grab enable X11 grabbing [no]
- (zero? (system*
- "./configure"
- (string-append "--prefix=" out)
- ;; Add $libdir to the RUNPATH of all the binaries.
- (string-append "--extra-ldflags=-Wl,-rpath="
- %output "/lib")
- "--enable-avresample"
- "--enable-gpl" ; enable optional gpl licensed parts
- "--enable-shared"
- "--enable-fontconfig"
- ;; "--enable-gnutls" ; causes test failures
- "--enable-ladspa"
- "--enable-libass"
- "--enable-libbluray"
- "--enable-libcaca"
- "--enable-libcdio"
- "--enable-libfreetype"
- "--enable-libmp3lame"
- "--enable-libopus"
- "--enable-libpulse"
- "--enable-libquvi"
- "--enable-libsoxr"
- "--enable-libspeex"
- "--enable-libtheora"
- "--enable-libtwolame"
- "--enable-libvorbis"
- "--enable-libvpx"
- "--enable-libxvid"
- "--enable-libx264"
- "--enable-openal"
-
- "--enable-runtime-cpudetect"
-
- ;; Runtime cpu detection is not implemented on
- ;; MIPS, so we disable some features.
- "--disable-mips32r2"
- "--disable-mipsdspr1"
- "--disable-mipsdspr2"
- "--disable-mipsfpu")))))
+ (zero? (apply system*
+ "./configure"
+ (string-append "--prefix=" out)
+ ;; Add $libdir to the RUNPATH of all the binaries.
+ (string-append "--extra-ldflags=-Wl,-rpath="
+ out "/lib")
+ configure-flags)))))
(add-before
'check 'set-ld-library-path
(lambda _
@@ -797,7 +811,7 @@ projects while introducing many more.")
(define-public youtube-dl
(package
(name "youtube-dl")
- (version "2015.10.16")
+ (version "2015.10.24")
(source (origin
(method url-fetch)
(uri (string-append "https://youtube-dl.org/downloads/"
@@ -805,7 +819,7 @@ projects while introducing many more.")
version ".tar.gz"))
(sha256
(base32
- "001a4md0yl3zx129mksmwc85grss67r3c9rynvranf9vlpv202vn"))))
+ "1q9srq08vb2yzl81hmjrgqwajckq52fhh9ag2ppbbxjibf91w5gs"))))
(build-system python-build-system)
(inputs `(("setuptools" ,python-setuptools)))
(home-page "http://youtube-dl.org")
diff --git a/gnu/packages/xfce.scm b/gnu/packages/xfce.scm
index ae10929bf2..a4987c1b2e 100644
--- a/gnu/packages/xfce.scm
+++ b/gnu/packages/xfce.scm
@@ -423,7 +423,10 @@ your system in categories, so you can quickly find and launch them.")
"/src/" name "-" version ".tar.bz2"))
(sha256
(base32
- "01kvbd09c06j20n155hracsgrq06rlmfgdywffjsvlwpn19m9j38"))))
+ "01kvbd09c06j20n155hracsgrq06rlmfgdywffjsvlwpn19m9j38"))
+ (patches
+ ;; See: https://bugzilla.xfce.org/show_bug.cgi?id=12282
+ (list (search-patch "xfce4-session-fix-xflock4.patch")))))
(build-system gnu-build-system)
(arguments
'(#:configure-flags
diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm
index b85a9c3aaf..54c15dd8ff 100644
--- a/gnu/packages/xorg.scm
+++ b/gnu/packages/xorg.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Eric Dvorsak <eric@dvorsak.fr>
+;;; Copyright © 2015 Cyrill Schenkel <cyrill.schenkel@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -5439,3 +5440,44 @@ perl programs to display windows and graphics on X11 servers.")
;; of the extension modules in the directory Protocol/Ext: see those files
;; for details)."
(license (package-license perl))))
+
+(define-public xcompmgr
+ (package
+ (name "xcompmgr")
+ (version "1.1.7")
+ (source
+ (origin
+ ;; there's no current tarball
+ (method git-fetch)
+ (uri (git-reference
+ (url "http://anongit.freedesktop.org/git/xorg/app/xcompmgr.git")
+ (commit (string-append name "-" version))))
+ (sha256
+ (base32
+ "04swkrm3gk689wrjc418bd3n25w8r20kg1xfbn5j8d7mx1r5gf16"))
+ (file-name (string-append name "-" version))))
+ (build-system gnu-build-system)
+ (arguments
+ `(#:phases (modify-phases %standard-phases
+ (add-after 'unpack 'autogen
+ (lambda _
+ (setenv "NOCONFIGURE" "t")
+ (zero? (system* "sh" "autogen.sh")))))))
+ (native-inputs
+ `(("pkg-config" ,pkg-config)
+ ("autoconf" ,autoconf)
+ ("automake" ,automake)))
+ (inputs
+ `(("libX11" ,libx11)
+ ("libXext" ,libxext)
+ ("libXcomposite" ,libxcomposite)
+ ("libXfixes" ,libxfixes)
+ ("libXdamage" ,libxdamage)
+ ("libXrender" ,libxrender)))
+ (synopsis "X Compositing manager using RENDER")
+ (description "xcompmgr is a sample compositing manager for X servers
+supporting the XFIXES, DAMAGE, RENDER, and COMPOSITE extensions. It enables
+basic eye-candy effects.")
+ (home-page "http://cgit.freedesktop.org/xorg/app/xcompmgr/")
+ (license (license:x11-style
+ "http://cgit.freedesktop.org/xorg/app/xcompmgr/tree/COPYING"))))
diff --git a/gnu/services.scm b/gnu/services.scm
index d0fe0ade17..c8a2a2604f 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -48,6 +48,7 @@
service-kind
service-parameters
+ modify-services
service-back-edges
fold-services
@@ -62,6 +63,7 @@
boot-service-type
activation-service-type
activation-service->script
+ %linux-bare-metal-service
etc-service-type
etc-directory
setuid-program-service-type
@@ -133,6 +135,47 @@
(parameters service-parameters))
+(define-syntax %modify-service
+ (syntax-rules (=>)
+ ((_ service)
+ service)
+ ((_ svc (kind param => exp ...) clauses ...)
+ (if (eq? (service-kind svc) kind)
+ (let ((param (service-parameters svc)))
+ (service (service-kind svc)
+ (begin exp ...)))
+ (%modify-service svc clauses ...)))))
+
+(define-syntax modify-services
+ (syntax-rules ()
+ "Modify the services listed in SERVICES according to CLAUSES. Each clause
+must have the form:
+
+ (TYPE VARIABLE => BODY)
+
+where TYPE is a service type, such as 'guix-service-type', and VARIABLE is an
+identifier that is bound within BODY to the value of the service of that
+TYPE. Consider this example:
+
+ (modify-services %base-services
+ (guix-service-type config =>
+ (guix-configuration
+ (inherit config)
+ (use-substitutes? #f)
+ (extra-options '(\"--gc-keep-derivations\"))))
+ (mingetty-service-type config =>
+ (mingetty-configuration
+ (inherit config)
+ (motd (plain-file \"motd\" \"Hi there!\")))))
+
+It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of
+all the MINGETTY-SERVICE-TYPE instances.
+
+This is a shorthand for (map (lambda (svc) ...) %base-services)."
+ ((_ services clauses ...)
+ (map (lambda (service)
+ (%modify-service service clauses ...))
+ services))))
;;;
@@ -202,20 +245,6 @@ file."
(union-build #$output '#$things))
#:modules '((guix build union))))))
-(define (modprobe-wrapper)
- "Return a wrapper for the 'modprobe' command that knows where modules live.
-
-This wrapper is typically invoked by the Linux kernel ('call_modprobe', in
-kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment
-variable is not set---hence the need for this wrapper."
- (let ((modprobe "/run/current-system/profile/bin/modprobe"))
- (gexp->script "modprobe"
- #~(begin
- (setenv "LINUX_MODULE_DIRECTORY"
- "/run/booted-system/kernel/lib/modules")
- (apply execl #$modprobe
- (cons #$modprobe (cdr (command-line))))))))
-
(define* (activation-service->script service)
"Return as a monadic value the activation script for SERVICE, a service of
ACTIVATION-SCRIPT-TYPE."
@@ -240,8 +269,7 @@ ACTIVATION-SCRIPT-TYPE."
(mlet* %store-monad ((actions (service-activations))
(modules (imported-modules %modules))
- (compiled (compiled-modules %modules))
- (modprobe (modprobe-wrapper)))
+ (compiled (compiled-modules %modules)))
(gexp->file "activate"
#~(begin
(eval-when (expand load eval)
@@ -256,12 +284,6 @@ ACTIVATION-SCRIPT-TYPE."
(activate-/bin/sh
(string-append #$(canonical-package bash) "/bin/sh"))
- ;; Tell the kernel to use our 'modprobe' command.
- (activate-modprobe #$modprobe)
-
- ;; Let users debug their own processes!
- (activate-ptrace-attach)
-
;; Run the services' activation snippets.
;; TODO: Use 'load-compiled'.
(for-each primitive-load '#$actions)
@@ -287,6 +309,41 @@ ACTIVATION-SCRIPT-TYPE."
;; receives.
(service activation-service-type #t))
+(define %modprobe-wrapper
+ ;; Wrapper for the 'modprobe' command that knows where modules live.
+ ;;
+ ;; This wrapper is typically invoked by the Linux kernel ('call_modprobe',
+ ;; in kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY'
+ ;; environment variable is not set---hence the need for this wrapper.
+ (let ((modprobe "/run/current-system/profile/bin/modprobe"))
+ (program-file "modprobe"
+ #~(begin
+ (setenv "LINUX_MODULE_DIRECTORY"
+ "/run/booted-system/kernel/lib/modules")
+ (apply execl #$modprobe
+ (cons #$modprobe (cdr (command-line))))))))
+
+(define %linux-kernel-activation
+ ;; Activation of the Linux kernel running on the bare metal (as opposed to
+ ;; running in a container.)
+ #~(begin
+ ;; Tell the kernel to use our 'modprobe' command.
+ (activate-modprobe #$%modprobe-wrapper)
+
+ ;; Let users debug their own processes!
+ (activate-ptrace-attach)))
+
+(define linux-bare-metal-service-type
+ (service-type (name 'linux-bare-metal)
+ (extensions
+ (list (service-extension activation-service-type
+ (const %linux-kernel-activation))))))
+
+(define %linux-bare-metal-service
+ ;; The service that does things that are needed on the "bare metal", but not
+ ;; necessary or impossible in a container.
+ (service linux-bare-metal-service-type #f))
+
(define (etc-directory service)
"Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE."
(files->etc-directory (service-parameters service)))
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 336cc4dec9..604416b985 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -57,6 +57,7 @@
mingetty-configuration
mingetty-configuration?
mingetty-service
+ mingetty-service-type
%nscd-default-caches
%nscd-default-configuration
@@ -74,6 +75,7 @@
guix-configuration
guix-configuration?
guix-service
+ guix-service-type
%base-services))
@@ -142,6 +144,18 @@ FILE-SYSTEM."
(symbol-append 'file-system-
(string->symbol (file-system-mount-point file-system))))
+(define (mapped-device->dmd-service-name md)
+ "Return the symbol that denotes the dmd service of MD, a <mapped-device>."
+ (symbol-append 'device-mapping-
+ (string->symbol (mapped-device-target md))))
+
+(define dependency->dmd-service-name
+ (match-lambda
+ ((? mapped-device? md)
+ (mapped-device->dmd-service-name md))
+ ((? file-system? fs)
+ (file-system->dmd-service-name fs))))
+
(define file-system-service-type
;; TODO(?): Make this an extensible service that takes <file-system> objects
;; and returns a list of <dmd-service>.
@@ -158,7 +172,7 @@ FILE-SYSTEM."
(dmd-service
(provision (list (file-system->dmd-service-name file-system)))
(requirement `(root-file-system
- ,@(map file-system->dmd-service-name dependencies)))
+ ,@(map dependency->dmd-service-name dependencies)))
(documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args
;; FIXME: Use or factorize with 'mount-file-system'.
@@ -751,6 +765,8 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(default #t))
(use-substitutes? guix-configuration-use-substitutes? ;Boolean
(default #t))
+ (substitute-urls guix-configuration-substitute-urls ;list of strings
+ (default %default-substitute-urls))
(extra-options guix-configuration-extra-options ;list of strings
(default '()))
(lsof guix-configuration-lsof ;<package>
@@ -765,7 +781,8 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
"Return a <dmd-service> for the Guix daemon service with CONFIG."
(match config
(($ <guix-configuration> guix build-group build-accounts authorize-key?
- use-substitutes? extra-options lsof lsh)
+ use-substitutes? substitute-urls extra-options
+ lsof lsh)
(list (dmd-service
(documentation "Run the Guix daemon.")
(provision '(guix-daemon))
@@ -777,6 +794,7 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
#$@(if use-substitutes?
'()
'("--no-substitutes"))
+ "--substitute-urls" #$(string-join substitute-urls)
#$@extra-options)
;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index 87d3eaa1b0..166895663f 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -34,6 +34,8 @@
#:use-module (gnu packages gnome)
#:use-module (gnu packages avahi)
#:use-module (gnu packages polkit)
+ #:use-module (gnu packages xdisorg)
+ #:use-module (gnu packages suckless)
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix store)
@@ -599,6 +601,10 @@ when they log out."
;; List of services typically useful for a "desktop" use case.
(cons* (slim-service)
+ ;; Screen lockers are a pretty useful thing and these are small.
+ (screen-locker-service slock)
+ (screen-locker-service xlockmore "xlock")
+
;; The D-Bus clique.
(avahi-service)
(wicd-service)
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index 3a57891a96..639a541777 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -32,16 +32,21 @@
#:use-module (gnu packages bash)
#:use-module (guix gexp)
#:use-module (guix store)
+ #:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix records)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (xorg-configuration-file
xorg-start-command
%default-slim-theme
%default-slim-theme-name
- slim-service))
+ slim-service
+
+ screen-locker-service-type
+ screen-locker-service))
;;; Commentary:
;;;
@@ -350,4 +355,52 @@ theme."
(auto-login-session auto-login-session)
(startx startx))))
+
+;;;
+;;; Screen lockers & co.
+;;;
+
+(define-record-type <screen-locker>
+ (screen-locker name program empty?)
+ screen-locker?
+ (name screen-locker-name) ;string
+ (program screen-locker-program) ;gexp
+ (empty? screen-locker-allows-empty-passwords?)) ;Boolean
+
+(define screen-locker-pam-services
+ (match-lambda
+ (($ <screen-locker> name _ empty?)
+ (list (unix-pam-service name
+ #:allow-empty-passwords? empty?)))))
+
+(define screen-locker-setuid-programs
+ (compose list screen-locker-program))
+
+(define screen-locker-service-type
+ (service-type (name 'screen-locker)
+ (extensions
+ (list (service-extension pam-root-service-type
+ screen-locker-pam-services)
+ (service-extension setuid-program-service-type
+ screen-locker-setuid-programs)))))
+
+(define* (screen-locker-service package
+ #:optional
+ (program (package-name package))
+ #:key allow-empty-passwords?)
+ "Add @var{package}, a package for a screen-locker or screen-saver whose
+command is @var{program}, to the set of setuid programs and add a PAM entry
+for it. For example:
+
+@lisp
+(screen-locker-service xlockmore \"xlock\")
+@end lisp
+
+makes the good ol' XlockMore usable."
+ (service screen-locker-service-type
+ (screen-locker program
+ #~(string-append #$package
+ #$(string-append "/bin/" program))
+ allow-empty-passwords?)))
+
;;; xorg.scm ends here
diff --git a/gnu/system.scm b/gnu/system.scm
index aa768824d9..3d570c0d1f 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -195,19 +195,16 @@ as 'needed-for-boot'."
(file-system-device fs)))
(operating-system-mapped-devices os)))
- (define (requirements fs)
- ;; XXX: Fiddling with dmd service names is not nice.
- (append (map (lambda (fs)
- (symbol-append 'file-system-
- (string->symbol
- (file-system-mount-point fs))))
- (file-system-dependencies fs))
- (map (lambda (md)
- (symbol-append 'device-mapping-
- (string->symbol (mapped-device-target md))))
- (device-mappings fs))))
-
- (map file-system-service file-systems))
+ (define (add-dependencies fs)
+ ;; Add the dependencies due to device mappings to FS.
+ (file-system
+ (inherit fs)
+ (dependencies
+ (delete-duplicates (append (device-mappings fs)
+ (file-system-dependencies fs))
+ eq?))))
+
+ (map (compose file-system-service add-dependencies) file-systems))
(define (mapped-device-user device file-systems)
"Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
@@ -290,7 +287,8 @@ a container or that of a \"bare metal\" system."
;; container.
(if container?
'()
- (list (service firmware-service-type
+ (list %linux-bare-metal-service
+ (service firmware-service-type
(operating-system-firmware os))))))))
(define* (operating-system-services os #:key container?)
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 8155b273e3..0a4b385fe3 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -99,9 +99,8 @@
(default #t))
(create-mount-point? file-system-create-mount-point? ; Boolean
(default #f))
- (dependencies file-system-dependencies ; list of strings (mount
- ; points depended on)
- (default '())))
+ (dependencies file-system-dependencies ; list of <file-system>
+ (default '()))) ; or <mapped-device>
(define-inlinable (file-system-needed-for-boot? fs)
"Return true if FS has the 'needed-for-boot?' flag set, or if it's the root
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index e49b6dbe54..4c21851cb6 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -30,6 +30,7 @@
#:autoload (gnu packages imagemagick) (imagemagick)
#:autoload (gnu packages compression) (gzip)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:export (grub-image
grub-image?
@@ -152,10 +153,26 @@ WIDTH/HEIGHT, or #f if none was found."
(with-monad %store-monad
(return #f)))))
-(define (eye-candy config port)
+(define (eye-candy config system port)
"Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the
'grub.cfg' part concerned with graphics mode, background images, colors, and
all that."
+ (define setup-gfxterm-body
+ ;; Intel systems need to be switched into graphics mode, whereas most
+ ;; other modern architectures have no other mode and therefore don't need
+ ;; to be switched.
+ (if (string-match "^(x86_64|i[3-6]86)-" system)
+ "
+ # Leave 'gfxmode' to 'auto'.
+ insmod vbe
+ insmod vga
+ insmod video_bochs
+ insmod video_cirrus
+ insmod gfxterm
+ terminal_output gfxterm
+"
+ ""))
+
(define (theme-colors type)
(let* ((theme (grub-configuration-theme config))
(colors (type theme)))
@@ -163,22 +180,15 @@ all that."
(symbol->string (assoc-ref colors 'bg)))))
(mlet* %store-monad ((image (grub-background-image config)))
- (return (and image #~(format #$port "
-function load_video {
- insmod vbe
- insmod vga
- insmod video_bochs
- insmod video_cirrus
-}
+ (return (and image
+ #~(format #$port "
+function setup_gfxterm {~a}
# Set 'root' to the partition that contains /gnu/store.
search --file --set ~a/share/grub/unicode.pf2
if loadfont ~a/share/grub/unicode.pf2; then
- set gfxmode=640x480
- load_video
- insmod gfxterm
- terminal_output gfxterm
+ setup_gfxterm
fi
insmod png
@@ -189,10 +199,11 @@ else
set menu_color_normal=cyan/blue
set menu_color_highlight=white/blue
fi~%"
- #$grub #$grub
- #$image
- #$(theme-colors grub-theme-color-normal)
- #$(theme-colors grub-theme-color-highlight))))))
+ #$setup-gfxterm-body
+ #$grub #$grub
+ #$image
+ #$(theme-colors grub-theme-color-normal)
+ #$(theme-colors grub-theme-color-highlight))))))
;;;
@@ -206,6 +217,11 @@ fi~%"
"Return the GRUB configuration file corresponding to CONFIG, a
<grub-configuration> object. OLD-ENTRIES is taken to be a list of menu
entries corresponding to old generations of the system."
+ (define linux-image-name
+ (if (string-prefix? "mips" system)
+ "vmlinuz"
+ "bzImage"))
+
(define all-entries
(append entries (grub-configuration-menu-entries config)))
@@ -214,16 +230,17 @@ entries corresponding to old generations of the system."
(($ <menu-entry> label linux arguments initrd)
#~(format port "menuentry ~s {
# Set 'root' to the partition that contains the kernel.
- search --file --set ~a/bzImage~%
+ search --file --set ~a/~a~%
- linux ~a/bzImage ~a
+ linux ~a/~a ~a
initrd ~a
}~%"
#$label
- #$linux #$linux (string-join (list #$@arguments))
+ #$linux #$linux-image-name
+ #$linux #$linux-image-name (string-join (list #$@arguments))
#$initrd))))
- (mlet %store-monad ((sugar (eye-candy config #~port)))
+ (mlet %store-monad ((sugar (eye-candy config system #~port)))
(define builder
#~(call-with-output-file #$output
(lambda (port)
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 519373fe34..6130e020c8 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -178,11 +178,13 @@ loaded at boot time in the order in which they appear."
(define linux-modules
;; Modules added to the initrd and loaded from the initrd.
`("ahci" ;for SATA controllers
- "pata_acpi" "pata_atiixp" ;for ATA controllers
- "isci" ;for SAS controllers like Intel C602
"usb-storage" "uas" ;for the installation image etc.
"usbkbd" "usbhid" ;USB keyboards, for debugging
"dm-crypt" "xts" ;for encrypted root partitions
+ ,@(if (string-match "^(x86_64|i[3-6]86)-" (%current-system))
+ '("pata_acpi" "pata_atiixp" ;for ATA controllers
+ "isci") ;for SAS controllers like Intel C602
+ '())
,@(if (or virtio? qemu-networking?)
virtio-modules
'())
diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm
index cd14bc97be..487d379e65 100644
--- a/gnu/system/linux.scm
+++ b/gnu/system/linux.scm
@@ -182,8 +182,7 @@ authenticate to run COMMAND."
;; These programs are setuid-root.
(map (cut unix-pam-service <>
#:allow-empty-passwords? allow-empty-passwords?)
- '("su" "passwd" "sudo"
- "xlock" "xscreensaver"))
+ '("su" "passwd" "sudo"))
;; These programs are not setuid-root, and we want root to be able
;; to run them without having to authenticate (notably because
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index c0cb789581..4506e96af9 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
+;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -96,6 +97,14 @@ and parameters ~s~%"
'("--enable-tests")
'())
configure-flags)))
+ ;; For packages where the Cabal build-type is set to "Configure",
+ ;; ./configure will be executed. In these cases, the following
+ ;; environment variable is needed to be able to find the shell executable.
+ ;; For other package types, the configure script isn't present. For more
+ ;; information, see the Build Information section of
+ ;; <https://www.haskell.org/cabal/users-guide/developing-packages.html>.
+ (when (file-exists? "configure")
+ (setenv "CONFIG_SHELL" "sh"))
(run-setuphs "configure" params)))
(define* (build #:rest empty)
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 5af1b884ce..e1455ccb98 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -413,8 +413,10 @@ for instance, whose releases are now uploaded to elpa.gnu.org."
(gnu-package? package)))
(define %gnu-updater
- (upstream-updater 'gnu
- non-emacs-gnu-package?
- latest-release*))
+ (upstream-updater
+ (name 'gnu)
+ (description "Updater for GNU packages")
+ (pred non-emacs-gnu-package?)
+ (latest latest-release*)))
;;; gnu-maintenance.scm ends here
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 6284c9eef3..4b53d5e2c2 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -236,8 +236,10 @@ representation of the package page."
(string-prefix? "r-" (package-name package)))
(define %cran-updater
- (upstream-updater 'cran
- cran-package?
- latest-release))
+ (upstream-updater
+ (name 'cran)
+ (description "Updater for CRAN packages")
+ (pred cran-package?)
+ (latest latest-release)))
;;; cran.scm ends here
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 37fc2b80fe..8c10668293 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -272,8 +272,10 @@ as \"debbugs\"."
(define %elpa-updater
;; The ELPA updater. We restrict it to packages hosted on elpa.gnu.org
;; because for other repositories, we typically grab the source elsewhere.
- (upstream-updater 'elpa
- package-from-gnu.org?
- latest-release))
+ (upstream-updater
+ (name 'elpa)
+ (description "Updater for ELPA packages")
+ (pred package-from-gnu.org?)
+ (latest latest-release)))
;;; elpa.scm ends here
diff --git a/guix/profiles.scm b/guix/profiles.scm
index fac322bbab..e8bd564efa 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -84,13 +84,17 @@
packages->manifest
%default-profile-hooks
profile-derivation
+
generation-number
generation-numbers
profile-generations
relative-generation
previous-generation-number
generation-time
- generation-file-name))
+ generation-file-name
+ switch-to-generation
+ roll-back
+ delete-generation))
;;; Commentary:
;;;
@@ -844,4 +848,78 @@ case when generations have been deleted (there are \"holes\")."
(make-time time-utc 0
(stat:ctime (stat (generation-file-name profile number)))))
+(define (link-to-empty-profile store generation)
+ "Link GENERATION, a string, to the empty profile. An error is raised if
+that fails."
+ (let* ((drv (run-with-store store
+ (profile-derivation (manifest '()))))
+ (prof (derivation->output-path drv "out")))
+ (build-derivations store (list drv))
+ (switch-symlinks generation prof)))
+
+(define (switch-to-generation profile number)
+ "Atomically switch PROFILE to the generation NUMBER. Return the number of
+the generation that was current before switching."
+ (let ((current (generation-number profile))
+ (generation (generation-file-name profile number)))
+ (cond ((not (file-exists? profile))
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
+ ((not (file-exists? generation))
+ (raise (condition (&missing-generation-error
+ (profile profile)
+ (generation number)))))
+ (else
+ (switch-symlinks profile generation)
+ current))))
+
+(define (switch-to-previous-generation profile)
+ "Atomically switch PROFILE to the previous generation. Return the former
+generation number and the current one."
+ (let ((previous (previous-generation-number profile)))
+ (values (switch-to-generation profile previous)
+ previous)))
+
+(define (roll-back store profile)
+ "Roll back to the previous generation of PROFILE. Return the number of the
+generation that was current before switching and the new generation number."
+ (let* ((number (generation-number profile))
+ (previous-number (previous-generation-number profile number))
+ (previous-generation (generation-file-name profile previous-number)))
+ (cond ((not (file-exists? profile)) ;invalid profile
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
+ ((zero? number) ;empty profile
+ (values number number))
+ ((or (zero? previous-number) ;going to emptiness
+ (not (file-exists? previous-generation)))
+ (link-to-empty-profile store previous-generation)
+ (switch-to-previous-generation profile))
+ (else ;anything else
+ (switch-to-previous-generation profile)))))
+
+(define (delete-generation store profile number)
+ "Delete generation with NUMBER from PROFILE. Return the file name of the
+generation that has been deleted, or #f if nothing was done (for instance
+because the NUMBER is zero.)"
+ (define (delete-and-return)
+ (let ((generation (generation-file-name profile number)))
+ (delete-file generation)
+ generation))
+
+ (let* ((current-number (generation-number profile))
+ (previous-number (previous-generation-number profile number))
+ (previous-generation (generation-file-name profile previous-number)))
+ (cond ((zero? number) #f) ;do not delete generation 0
+ ((and (= number current-number)
+ (not (file-exists? previous-generation)))
+ (link-to-empty-profile store previous-generation)
+ (switch-to-previous-generation profile)
+ (delete-and-return))
+ ((= number current-number)
+ (roll-back store profile)
+ (delete-and-return))
+ (else
+ (delete-and-return)))))
+
;;; profiles.scm ends here
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index a357cf8aa4..644ffe8d6e 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -185,8 +185,7 @@ options handled by 'set-build-options-from-command-line', and listed in
#:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes? (assoc-ref opts 'substitutes?)
- #:substitute-urls (or (assoc-ref opts 'substitute-urls)
- %default-substitute-urls)
+ #:substitute-urls (assoc-ref opts 'substitute-urls)
#:use-build-hook? (assoc-ref opts 'build-hook?)
#:max-silent-time (assoc-ref opts 'max-silent-time)
#:timeout (assoc-ref opts 'timeout)
@@ -290,6 +289,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(display (_ "
-e, --expression=EXPR build the package or derivation EXPR evaluates to"))
(display (_ "
+ -f, --file=FILE build the package or derivation that the code within
+ FILE evaluates to"))
+ (display (_ "
-S, --source build the packages' source derivations"))
(display (_ "
--sources[=TYPE] build source derivations; TYPE may optionally be one
@@ -359,6 +361,9 @@ must be one of 'package', 'all', or 'transitive'~%")
(option '(#\e "expression") #t #f
(lambda (opt name arg result)
(alist-cons 'expression arg result)))
+ (option '(#\f "file") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'file arg result)))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
(alist-cons 'dry-run? #t result)))
@@ -422,29 +427,34 @@ packages."
(define system
(or (assoc-ref opts 'system) (%current-system)))
+ (define (object->argument obj)
+ (match obj
+ ((? package? p)
+ `(argument . ,p))
+ ((? procedure? proc)
+ (let ((drv (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (proc))
+ #:system system)))
+ `(argument . ,drv)))
+ ((? gexp? gexp)
+ (let ((drv (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (gexp->derivation "gexp" gexp
+ #:system system)))))
+ `(argument . ,drv)))))
+
(map (match-lambda
(('argument . (? string? spec))
(if (store-path? spec)
`(argument . ,spec)
`(argument . ,(specification->package spec))))
+ (('file . file)
+ (object->argument (load* file (make-user-module '()))))
(('expression . str)
- (match (read/eval str)
- ((? package? p)
- `(argument . ,p))
- ((? procedure? proc)
- (let ((drv (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (proc))
- #:system system)))
- `(argument . ,drv)))
- ((? gexp? gexp)
- (let ((drv (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (gexp->derivation "gexp" gexp
- #:system system)))))
- `(argument . ,drv)))))
+ (object->argument (read/eval str)))
(opt opt))
opts))
@@ -501,6 +511,8 @@ arguments with packages that use the specified source."
(urls (map (cut string-append <> "/log")
(if (assoc-ref opts 'substitutes?)
(or (assoc-ref opts 'substitute-urls)
+ ;; XXX: This does not necessarily match the
+ ;; daemon's substitute URLs.
%default-substitute-urls)
'())))
(roots (filter-map (match-lambda
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 19a9b061b8..4a0c865b07 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -125,10 +125,8 @@ taken since we do not import the archives."
servers))
;; No 'assert-valid-narinfo' on purpose.
(narinfos -> (fold (lambda (narinfo vhash)
- (if narinfo
- (vhash-cons (narinfo-path narinfo) narinfo
- vhash)
- vhash))
+ (vhash-cons (narinfo-path narinfo) narinfo
+ vhash))
vlist-null
remote)))
(return (filter-map (lambda (item local)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 2408420e18..188838574f 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -25,13 +25,19 @@
#:use-module (guix profiles)
#:use-module (guix search-paths)
#:use-module (guix utils)
+ #:use-module (guix build utils)
#:use-module (guix monads)
#:use-module ((guix gexp) #:select (lower-inputs))
#:use-module (guix scripts)
#:use-module (guix scripts build)
+ #:use-module (gnu build linux-container)
+ #:use-module (gnu system linux-container)
+ #:use-module (gnu system file-systems)
#:use-module (gnu packages)
+ #:use-module (gnu packages bash)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@@ -60,6 +66,12 @@ OUTPUT) tuples."
(define %default-shell
(or (getenv "SHELL") "/bin/sh"))
+(define %network-configuration-files
+ '("/etc/resolv.conf"
+ "/etc/nsswitch.conf"
+ "/etc/services"
+ "/etc/hosts"))
+
(define (purify-environment)
"Unset almost all environment variables. A small number of variables such
as 'HOME' and 'USER' are left untouched."
@@ -124,6 +136,18 @@ COMMAND or an interactive shell in that environment.\n"))
--search-paths display needed environment variable definitions"))
(display (_ "
-s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
+ (display (_ "
+ -C, --container run command within an isolated container"))
+ (display (_ "
+ -N, --network allow containers to access the network"))
+ (display (_ "
+ --share=SPEC for containers, share writable host file system
+ according to SPEC"))
+ (display (_ "
+ --expose=SPEC for containers, expose read-only host file system
+ according to SPEC"))
+ (display (_ "
+ --bootstrap use bootstrap binaries to build the environment"))
(newline)
(show-build-options-help)
(newline)
@@ -142,6 +166,16 @@ COMMAND or an interactive shell in that environment.\n"))
(max-silent-time . 3600)
(verbosity . 0)))
+(define (tag-package-arg opts arg)
+ "Return a two-element list with the form (TAG ARG) that tags ARG with either
+'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise."
+ ;; Normally, the transitive inputs to a package are added to an environment,
+ ;; but the ad-hoc? flag changes the meaning of a package argument such that
+ ;; the package itself is added to the environment instead.
+ (if (assoc-ref opts 'ad-hoc?)
+ `(ad-hoc-package ,arg)
+ `(package ,arg)))
+
(define %options
;; Specification of the command-line options.
(cons* (option '(#\h "help") #f #f
@@ -162,10 +196,14 @@ COMMAND or an interactive shell in that environment.\n"))
(alist-cons 'search-paths #t result)))
(option '(#\l "load") #t #f
(lambda (opt name arg result)
- (alist-cons 'load arg result)))
+ (alist-cons 'load
+ (tag-package-arg result arg)
+ result)))
(option '(#\e "expression") #t #f
(lambda (opt name arg result)
- (alist-cons 'expression arg result)))
+ (alist-cons 'expression
+ (tag-package-arg result arg)
+ result)))
(option '("ad-hoc") #f #f
(lambda (opt name arg result)
(alist-cons 'ad-hoc? #t result)))
@@ -176,6 +214,25 @@ COMMAND or an interactive shell in that environment.\n"))
(lambda (opt name arg result)
(alist-cons 'system arg
(alist-delete 'system result eq?))))
+ (option '(#\C "container") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'container? #t result)))
+ (option '(#\N "network") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'network? #t result)))
+ (option '("share") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'file-system-mapping
+ (specification->file-system-mapping arg #t)
+ result)))
+ (option '("expose") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'file-system-mapping
+ (specification->file-system-mapping arg #f)
+ result)))
+ (option '("bootstrap") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'bootstrap? #t result)))
%standard-build-options))
(define (pick-all alist key)
@@ -189,29 +246,34 @@ COMMAND or an interactive shell in that environment.\n"))
(_ memo)))
'() alist))
+(define (compact lst)
+ "Remove all #f elements from LST."
+ (filter identity lst))
+
(define (options/resolve-packages opts)
"Return OPTS with package specification strings replaced by actual
packages."
- (append-map (match-lambda
- (('package . (? string? spec))
- (let-values (((package output)
- (specification->package+output spec)))
- `((package ,package ,output))))
- (('expression . str)
- ;; Add all the outputs of the package STR evaluates to.
- (match (read/eval str)
- ((? package? package)
+ (compact
+ (append-map (match-lambda
+ (('package mode (? string? spec))
+ (let-values (((package output)
+ (specification->package+output spec)))
+ (list (list mode package output))))
+ (('expression mode str)
+ ;; Add all the outputs of the package STR evaluates to.
+ (match (read/eval str)
+ ((? package? package)
+ (map (lambda (output)
+ (list mode package output))
+ (package-outputs package)))))
+ (('load mode file)
+ ;; Add all the outputs of the package defined in FILE.
+ (let ((package (load* file (make-user-module '()))))
(map (lambda (output)
- `(package ,package ,output))
- (package-outputs package)))))
- (('load . file)
- ;; Add all the outputs of the package defined in FILE.
- (let ((package (load* file (make-user-module '()))))
- (map (lambda (output)
- `(package ,package ,output))
- (package-outputs package))))
- (opt (list opt)))
- opts))
+ (list mode package output))
+ (package-outputs package))))
+ (_ '(#f)))
+ opts)))
(define (build-inputs inputs opts)
"Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION
@@ -231,10 +293,135 @@ OUTPUT) tuples, using the build options in OPTS."
(built-derivations derivations)
(return derivations))))))))
+(define requisites* (store-lift requisites))
+
+(define (inputs->requisites inputs)
+ "Convert INPUTS, a list of input tuples or store path strings, into a set of
+requisite store items i.e. the union closure of all the inputs."
+ (define (input->requisites input)
+ (requisites*
+ (match input
+ ((drv output)
+ (derivation->output-path drv output))
+ ((drv)
+ (derivation->output-path drv))
+ ((? direct-store-path? path)
+ path))))
+
+ (mlet %store-monad ((reqs (sequence %store-monad
+ (map input->requisites inputs))))
+ (return (delete-duplicates (concatenate reqs)))))
+
+(define exit/status (compose exit status:exit-val))
+(define primitive-exit/status (compose primitive-exit status:exit-val))
+
+(define (launch-environment command inputs paths pure?)
+ "Run COMMAND in a new environment containing INPUTS, using the native search
+paths defined by the list PATHS. When PURE?, pre-existing environment
+variables are cleared before setting the new ones."
+ (create-environment inputs paths pure?)
+ (apply system* command))
+
+(define* (launch-environment/container #:key command bash user-mappings
+ inputs paths network?)
+ "Run COMMAND within a Linux container. The environment features INPUTS, a
+list of derivations to be shared from the host system. Environment variables
+are set according to PATHS, a list of native search paths. The global shell
+is BASH, a file name for a GNU Bash binary in the store. When NETWORK?,
+access to the host system network is permitted. USER-MAPPINGS, a list of file
+system mappings, contains the user-specified host file systems to mount inside
+the container."
+ (mlet %store-monad ((reqs (inputs->requisites
+ (cons (direct-store-path bash) inputs))))
+ (return
+ (let* ((cwd (getcwd))
+ ;; Bind-mount all requisite store items, user-specified mappings,
+ ;; /bin/sh, the current working directory, and possibly networking
+ ;; configuration files within the container.
+ (mappings
+ (append user-mappings
+ ;; Current working directory.
+ (list (file-system-mapping
+ (source cwd)
+ (target cwd)
+ (writable? #t)))
+ ;; When in Rome, do as Nix build.cc does: Automagically
+ ;; map common network configuration files.
+ (if network?
+ (filter-map (lambda (file)
+ (and (file-exists? file)
+ (file-system-mapping
+ (source file)
+ (target file)
+ (writable? #f))))
+ %network-configuration-files)
+ '())
+ ;; Mappings for the union closure of all inputs.
+ (map (lambda (dir)
+ (file-system-mapping
+ (source dir)
+ (target dir)
+ (writable? #f)))
+ reqs)))
+ (file-systems (append %container-file-systems
+ (map mapping->file-system mappings))))
+ (exit/status
+ (call-with-container (map file-system->spec file-systems)
+ (lambda ()
+ ;; Setup global shell.
+ (mkdir-p "/bin")
+ (symlink bash "/bin/sh")
+
+ ;; Setup directory for temporary files.
+ (mkdir-p "/tmp")
+ (for-each (lambda (var)
+ (setenv var "/tmp"))
+ ;; The same variables as in Nix's 'build.cc'.
+ '("TMPDIR" "TEMPDIR" "TMP" "TEMP"))
+
+ ;; From Nix build.cc:
+ ;;
+ ;; Set HOME to a non-existing path to prevent certain
+ ;; programs from using /etc/passwd (or NIS, or whatever)
+ ;; to locate the home directory (for example, wget looks
+ ;; for ~/.wgetrc). I.e., these tools use /etc/passwd if
+ ;; HOME is not set, but they will just assume that the
+ ;; settings file they are looking for does not exist if
+ ;; HOME is set but points to some non-existing path.
+ (setenv "HOME" "/homeless-shelter")
+
+ ;; For convenience, start in the user's current working
+ ;; directory rather than the root directory.
+ (chdir cwd)
+
+ (primitive-exit/status
+ ;; A container's environment is already purified, so no need to
+ ;; request it be purified again.
+ (launch-environment command inputs paths #f)))
+ #:namespaces (if network?
+ (delq 'net %namespaces) ; share host network
+ %namespaces)))))))
+
+(define (environment-bash container? bootstrap? system)
+ "Return a monadic value in the store monad for the version of GNU Bash
+needed in the environment for SYSTEM, if any. If CONTAINER? is #f, return #f.
+If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash.
+Otherwise, return the derivation for the Bash package."
+ (with-monad %store-monad
+ (cond
+ ((and container? (not bootstrap?))
+ (package->derivation bash))
+ ;; Use the bootstrap Bash instead.
+ ((and container? bootstrap?)
+ (interned-file
+ (search-bootstrap-binary "bash" system)))
+ (else
+ (return #f)))))
+
(define (parse-args args)
"Parse the list of command line arguments ARGS."
(define (handle-argument arg result)
- (alist-cons 'package arg result))
+ (alist-cons 'package (tag-package-arg result arg) result))
;; The '--' token is used to separate the command to run from the rest of
;; the operands.
@@ -248,52 +435,74 @@ OUTPUT) tuples, using the build options in OPTS."
;; Entry point.
(define (guix-environment . args)
(with-error-handling
- (let* ((opts (parse-args args))
- (pure? (assoc-ref opts 'pure))
- (ad-hoc? (assoc-ref opts 'ad-hoc?))
- (command (assoc-ref opts 'exec))
- (packages (pick-all (options/resolve-packages opts) 'package))
- (inputs (if ad-hoc?
- (append-map (match-lambda
- ((package output)
- (package+propagated-inputs package
- output)))
- packages)
- (append-map (compose bag-transitive-inputs
- package->bag
- first)
- packages)))
- (paths (delete-duplicates
- (cons $PATH
- (append-map (match-lambda
- ((label (? package? p) _ ...)
- (package-native-search-paths p))
- (_
- '()))
- inputs))
- eq?)))
+ (let* ((opts (parse-args args))
+ (pure? (assoc-ref opts 'pure))
+ (container? (assoc-ref opts 'container?))
+ (network? (assoc-ref opts 'network?))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (system (assoc-ref opts 'system))
+ (command (assoc-ref opts 'exec))
+ (packages (options/resolve-packages opts))
+ (mappings (pick-all opts 'file-system-mapping))
+ (inputs (delete-duplicates
+ (append-map (match-lambda
+ (('ad-hoc-package package output)
+ (package+propagated-inputs package
+ output))
+ (('package package output)
+ (bag-transitive-inputs
+ (package->bag package))))
+ packages)))
+ (paths (delete-duplicates
+ (cons $PATH
+ (append-map (match-lambda
+ ((label (? package? p) _ ...)
+ (package-native-search-paths p))
+ (_
+ '()))
+ inputs))
+ eq?)))
(with-store store
(run-with-store store
- (mlet %store-monad ((inputs (lower-inputs
- (map (match-lambda
+ (mlet* %store-monad ((inputs (lower-inputs
+ (map (match-lambda
((label item)
(list item))
((label item output)
(list item output)))
- inputs)
- #:system (assoc-ref opts 'system))))
+ inputs)
+ #:system system))
+ ;; Containers need a Bourne shell at /bin/sh.
+ (bash (environment-bash container?
+ bootstrap?
+ system)))
(mbegin %store-monad
- ;; First build INPUTS. This is necessary even for
- ;; --search-paths.
- (build-inputs inputs opts)
- (cond ((assoc-ref opts 'dry-run?)
- (return #t))
- ((assoc-ref opts 'search-paths)
- (show-search-paths inputs paths pure?)
- (return #t))
- (else
- (create-environment inputs paths pure?)
- (return
- (exit
- (status:exit-val
- (apply system* command)))))))))))))
+ ;; First build the inputs. This is necessary even for
+ ;; --search-paths. Additionally, we might need to build bash
+ ;; for a container.
+ (build-inputs (if (derivation? bash)
+ `((,bash "out") ,@inputs)
+ inputs)
+ opts)
+ (cond
+ ((assoc-ref opts 'dry-run?)
+ (return #t))
+ ((assoc-ref opts 'search-paths)
+ (show-search-paths inputs paths pure?)
+ (return #t))
+ (container?
+ (let ((bash-binary
+ (if bootstrap?
+ bash
+ (string-append (derivation->output-path bash)
+ "/bin/sh"))))
+ (launch-environment/container #:command command
+ #:bash bash-binary
+ #:user-mappings mappings
+ #:inputs inputs
+ #:paths paths
+ #:network? network?)))
+ (else
+ (return
+ (exit/status
+ (launch-environment command inputs paths pure?))))))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index e0fe1ddb27..adbc4a1828 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -48,11 +48,7 @@
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
- #:export (switch-to-generation
- switch-to-previous-generation
- roll-back
- delete-generation
- delete-generations
+ #:export (delete-generations
display-search-paths
guix-package))
@@ -100,149 +96,12 @@ indirectly, or PROFILE."
%user-profile-directory
profile))
-(define (link-to-empty-profile store generation)
- "Link GENERATION, a string, to the empty profile."
- (let* ((drv (run-with-store store
- (profile-derivation (manifest '()))))
- (prof (derivation->output-path drv "out")))
- (when (not (build-derivations store (list drv)))
- (leave (_ "failed to build the empty profile~%")))
-
- (switch-symlinks generation prof)))
-
-(define (switch-to-generation profile number)
- "Atomically switch PROFILE to the generation NUMBER."
- (let ((current (generation-number profile))
- (generation (generation-file-name profile number)))
- (cond ((not (file-exists? profile))
- (raise (condition (&profile-not-found-error
- (profile profile)))))
- ((not (file-exists? generation))
- (raise (condition (&missing-generation-error
- (profile profile)
- (generation number)))))
- (else
- (format #t (_ "switching from generation ~a to ~a~%")
- current number)
- (switch-symlinks profile generation)))))
-
-(define (switch-to-previous-generation profile)
- "Atomically switch PROFILE to the previous generation."
- (switch-to-generation profile
- (previous-generation-number profile)))
-
-(define (roll-back store profile)
- "Roll back to the previous generation of PROFILE."
- (let* ((number (generation-number profile))
- (previous-number (previous-generation-number profile number))
- (previous-generation (generation-file-name profile previous-number)))
- (cond ((not (file-exists? profile)) ; invalid profile
- (raise (condition (&profile-not-found-error
- (profile profile)))))
- ((zero? number) ; empty profile
- (format (current-error-port)
- (_ "nothing to do: already at the empty profile~%")))
- ((or (zero? previous-number) ; going to emptiness
- (not (file-exists? previous-generation)))
- (link-to-empty-profile store previous-generation)
- (switch-to-previous-generation profile))
- (else
- (switch-to-previous-generation profile))))) ; anything else
-
-(define (delete-generation store profile number)
- "Delete generation with NUMBER from PROFILE."
- (define (display-and-delete)
- (let ((generation (generation-file-name profile number)))
- (format #t (_ "deleting ~a~%") generation)
- (delete-file generation)))
-
- (let* ((current-number (generation-number profile))
- (previous-number (previous-generation-number profile number))
- (previous-generation (generation-file-name profile previous-number)))
- (cond ((zero? number)) ; do not delete generation 0
- ((and (= number current-number)
- (not (file-exists? previous-generation)))
- (link-to-empty-profile store previous-generation)
- (switch-to-previous-generation profile)
- (display-and-delete))
- ((= number current-number)
- (roll-back store profile)
- (display-and-delete))
- (else
- (display-and-delete)))))
-
(define (delete-generations store profile generations)
"Delete GENERATIONS from PROFILE.
GENERATIONS is a list of generation numbers."
- (for-each (cut delete-generation store profile <>)
+ (for-each (cut delete-generation* store profile <>)
generations))
-(define* (matching-generations str #:optional (profile %current-profile)
- #:key (duration-relation <=))
- "Return the list of available generations matching a pattern in STR. See
-'string->generations' and 'string->duration' for the list of valid patterns.
-When STR is a duration pattern, return all the generations whose ctime has
-DURATION-RELATION with the current time."
- (define (valid-generations lst)
- (define (valid-generation? n)
- (any (cut = n <>) (generation-numbers profile)))
-
- (fold-right (lambda (x acc)
- (if (valid-generation? x)
- (cons x acc)
- acc))
- '()
- lst))
-
- (define (filter-generations generations)
- (match generations
- (() '())
- (('>= n)
- (drop-while (cut > n <>)
- (generation-numbers profile)))
- (('<= n)
- (valid-generations (iota n 1)))
- ((lst ..1)
- (valid-generations lst))
- (_ #f)))
-
- (define (filter-by-duration duration)
- (define (time-at-midnight time)
- ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
- ;; hours to zeros.
- (let ((d (time-utc->date time)))
- (date->time-utc
- (make-date 0 0 0 0
- (date-day d) (date-month d)
- (date-year d) (date-zone-offset d)))))
-
- (define generation-ctime-alist
- (map (lambda (number)
- (cons number
- (time-second
- (time-at-midnight
- (generation-time profile number)))))
- (generation-numbers profile)))
-
- (match duration
- (#f #f)
- (res
- (let ((s (time-second
- (subtract-duration (time-at-midnight (current-time))
- duration))))
- (delete #f (map (lambda (x)
- (and (duration-relation s (cdr x))
- (first x)))
- generation-ctime-alist))))))
-
- (cond ((string->generations str)
- =>
- filter-generations)
- ((string->duration str)
- =>
- filter-by-duration)
- (else #f)))
-
(define (delete-matching-generations store profile pattern)
"Delete from PROFILE all the generations matching PATTERN. PATTERN must be
a string denoting a set of generations: the empty list means \"all generations
@@ -576,14 +435,14 @@ return the new list of manifest entries."
(define upgrade-regexps
(filter-map (match-lambda
(('upgrade . regexp)
- (make-regexp (or regexp "")))
+ (make-regexp* (or regexp "")))
(_ #f))
opts))
(define do-not-upgrade-regexps
(filter-map (match-lambda
(('do-not-upgrade . regexp)
- (make-regexp regexp))
+ (make-regexp* regexp))
(_ #f))
opts))
@@ -678,34 +537,6 @@ doesn't need it."
(add-indirect-root store absolute))
-(define (readlink* file)
- "Call 'readlink' until the result is not a symlink."
- (define %max-symlink-depth 50)
-
- (let loop ((file file)
- (depth 0))
- (define (absolute target)
- (if (absolute-file-name? target)
- target
- (string-append (dirname file) "/" target)))
-
- (if (>= depth %max-symlink-depth)
- file
- (call-with-values
- (lambda ()
- (catch 'system-error
- (lambda ()
- (values #t (readlink file)))
- (lambda args
- (let ((errno (system-error-errno args)))
- (if (or (= errno EINVAL))
- (values #f file)
- (apply throw args))))))
- (lambda (success? target)
- (if success?
- (loop (absolute target) (+ depth 1))
- file))))))
-
;;;
;;; Entry point.
@@ -819,7 +650,7 @@ more information.~%"))
;; First roll back if asked to.
(cond ((and (assoc-ref opts 'roll-back?)
(not dry-run?))
- (roll-back (%store) profile)
+ (roll-back* (%store) profile)
(process-actions (alist-delete 'roll-back? opts)))
((and (assoc-ref opts 'switch-generation)
(not dry-run?))
@@ -833,7 +664,7 @@ more information.~%"))
(relative-generation profile number))
(else number)))))
(if number
- (switch-to-generation profile number)
+ (switch-to-generation* profile number)
(leave (_ "cannot switch to generation '~a'~%")
pattern)))
(process-actions (alist-delete 'switch-generation opts)))
@@ -883,25 +714,8 @@ more information.~%"))
(('list-generations pattern)
(define (list-generation number)
(unless (zero? number)
- (let ((header (format #f (_ "Generation ~a\t~a") number
- (date->string
- (time-utc->date
- (generation-time profile number))
- "~b ~d ~Y ~T")))
- (current (generation-number profile)))
- (if (= number current)
- (format #t (_ "~a\t(current)~%") header)
- (format #t "~a~%" header)))
- (for-each (match-lambda
- (($ <manifest-entry> name version output location _)
- (format #t " ~a\t~a\t~a\t~a~%"
- name version output location)))
-
- ;; Show most recently installed packages last.
- (reverse
- (manifest-entries
- (profile-manifest
- (generation-file-name profile number)))))
+ (display-generation profile number)
+ (display-profile-content profile number)
(newline)))
(cond ((not (file-exists? profile)) ; XXX: race condition
@@ -922,7 +736,7 @@ more information.~%"))
#t)
(('list-installed regexp)
- (let* ((regexp (and regexp (make-regexp regexp)))
+ (let* ((regexp (and regexp (make-regexp* regexp)))
(manifest (profile-manifest profile))
(installed (manifest-entries manifest)))
(leave-on-EPIPE
@@ -938,7 +752,7 @@ more information.~%"))
#t))
(('list-available regexp)
- (let* ((regexp (and regexp (make-regexp regexp)))
+ (let* ((regexp (and regexp (make-regexp* regexp)))
(available (fold-packages
(lambda (p r)
(let ((n (package-name p)))
@@ -964,7 +778,7 @@ more information.~%"))
#t))
(('search regexp)
- (let ((regexp (make-regexp regexp regexp/icase)))
+ (let ((regexp (make-regexp* regexp regexp/icase)))
(leave-on-EPIPE
(for-each (cute package->recutils <> (current-output-port))
(find-packages-by-description regexp)))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 56ee9acb18..a4824e4fd7 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -18,6 +18,7 @@
(define-module (guix scripts pull)
#:use-module (guix ui)
+ #:use-module (guix utils)
#:use-module (guix scripts)
#:use-module (guix store)
#:use-module (guix config)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 6f7ca4a41b..04f6b76edc 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -68,7 +69,13 @@
arg)))))
(option '(#\t "type") #t #f
(lambda (opt name arg result)
- (alist-cons 'updater (string->symbol arg) result)))
+ (let* ((not-comma (char-set-complement (char-set #\,)))
+ (names (map string->symbol
+ (string-tokenize arg not-comma))))
+ (alist-cons 'updaters names result))))
+ (option '(#\L "list-updaters") #f #f
+ (lambda args
+ (list-updaters-and-exit)))
(option '(#\l "list-dependent") #f #f
(lambda (opt name arg result)
(alist-cons 'list-dependent? #t result)))
@@ -110,7 +117,10 @@ specified with `--select'.\n"))
-s, --select=SUBSET select all the packages in SUBSET, one of
`core' or `non-core'"))
(display (_ "
- -t, --type=UPDATER restrict to updates from UPDATER--e.g., 'gnu'"))
+ -t, --type=UPDATER,... restrict to updates from the specified updaters
+ (e.g., 'gnu')"))
+ (display (_ "
+ -L, --list-updaters list available updaters and exit"))
(display (_ "
-l, --list-dependent list top-level dependent packages that would need to
be rebuilt as a result of upgrading PACKAGE..."))
@@ -149,6 +159,16 @@ specified with `--select'.\n"))
(eq? name (upstream-updater-name updater)))
%updaters))
+(define (list-updaters-and-exit)
+ "Display available updaters and exit."
+ (format #t (_ "Available updaters:~%"))
+ (for-each (lambda (updater)
+ (format #t "- ~a: ~a~%"
+ (upstream-updater-name updater)
+ (_ (upstream-updater-description updater))))
+ %updaters)
+ (exit 0))
+
(define* (update-package store package updaters
#:key (key-download 'interactive))
"Update the source file that defines PACKAGE with the new version.
@@ -193,15 +213,15 @@ downloaded and authenticated; not updating~%")
(define (options->updaters opts)
;; Return the list of updaters to use.
(match (filter-map (match-lambda
- (('updater . name)
- (lookup-updater name))
+ (('updaters . names)
+ (map lookup-updater names))
(_ #f))
opts)
(()
;; Use the default updaters.
%updaters)
- (lst
- lst)))
+ (lists
+ (concatenate lists))))
(define (keep-newest package lst)
;; If a newer version of PACKAGE is already in LST, return LST; otherwise
diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm
index 44ff92655b..e999cce1fd 100644
--- a/guix/scripts/size.scm
+++ b/guix/scripts/size.scm
@@ -252,8 +252,7 @@ Report the size of PACKAGE and its dependencies.\n"))
(show-version-and-exit "guix size")))))
(define %default-options
- `((system . ,(%current-system))
- (substitute-urls . ,%default-substitute-urls)))
+ `((system . ,(%current-system))))
;;;
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 8967fa062e..964df9422c 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -72,6 +72,7 @@
assert-valid-narinfo
lookup-narinfos
+ lookup-narinfos/diverse
read-narinfo
write-narinfo
guix-substitute))
@@ -474,12 +475,13 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
".narinfo")))
(build-request (string->uri url) #:method 'GET)))
-(define (http-multiple-get base-url requests proc)
+(define (http-multiple-get base-url proc seed requests)
"Send all of REQUESTS to the server at BASE-URL. Call PROC for each
-response, passing it the request object, the response, and a port from which
-to read the response body. Return the list of results."
+response, passing it the request object, the response, a port from which to
+read the response body, and the previous result, starting with SEED, à la
+'fold'. Return the final result."
(let connect ((requests requests)
- (result '()))
+ (result seed))
;; (format (current-error-port) "connecting (~a requests left)..."
;; (length requests))
(let ((p (open-socket-for-uri base-url)))
@@ -497,7 +499,7 @@ to read the response body. Return the list of results."
((head tail ...)
(let* ((resp (read-response p))
(body (response-body-port resp))
- (result (cons (proc head resp body) result)))
+ (result (proc head resp body result)))
;; The server can choose to stop responding at any time, in which
;; case we have to try again. Check whether that is the case.
;; Note that even upon "Connection: close", we can read from BODY.
@@ -536,7 +538,7 @@ if file doesn't exist, and the narinfo otherwise."
url (* 100. (/ done (length paths))))
(set! done (+ 1 done)))))
- (define (handle-narinfo-response request response port)
+ (define (handle-narinfo-response request response port result)
(let ((len (response-content-length response)))
;; Make sure to read no more than LEN bytes since subsequent bytes may
;; belong to the next response.
@@ -545,7 +547,7 @@ if file doesn't exist, and the narinfo otherwise."
(let ((narinfo (read-narinfo port url #:size len)))
(cache-narinfo! url (narinfo-path narinfo) narinfo)
(update-progress!)
- narinfo))
+ (cons narinfo result)))
((404) ; failure
(let* ((path (uri-path (request-uri request)))
(hash-part (string-drop-right path 8))) ; drop ".narinfo"
@@ -555,13 +557,13 @@ if file doesn't exist, and the narinfo otherwise."
(cache-narinfo! url
(find (cut string-contains <> hash-part) paths)
#f)
- (update-progress!))
- #f)
+ (update-progress!)
+ result))
(else ; transient failure
(if len
(get-bytevector-n port len)
(read-to-eof port))
- #f))))
+ result))))
(define cache-info
(download-cache-info url))
@@ -574,8 +576,9 @@ if file doesn't exist, and the narinfo otherwise."
((http)
(let ((requests (map (cut narinfo-request url <>) paths)))
(update-progress!)
- (let ((result (http-multiple-get url requests
- handle-narinfo-response)))
+ (let ((result (http-multiple-get url
+ handle-narinfo-response '()
+ requests)))
(newline (current-error-port))
result)))
((file #f)
@@ -596,7 +599,9 @@ information is available locally."
(let-values (((valid? value)
(cached-narinfo cache path)))
(if valid?
- (values (cons value cached) missing)
+ (if value
+ (values (cons value cached) missing)
+ (values cached missing))
(values cached (cons path missing)))))
'()
'()
@@ -606,11 +611,32 @@ information is available locally."
(let ((missing (fetch-narinfos cache missing)))
(append cached (or missing '()))))))
-(define (lookup-narinfo cache path)
- "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
-found."
- (match (lookup-narinfos cache (list path))
- ((answer) answer)))
+(define (lookup-narinfos/diverse caches paths)
+ "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
+That is, when a cache lacks a narinfo, look it up in the next cache, and so
+on. Return a list of narinfos for PATHS or a subset thereof."
+ (let loop ((caches caches)
+ (paths paths)
+ (result '()))
+ (match paths
+ (() ;we're done
+ result)
+ (_
+ (match caches
+ ((cache rest ...)
+ (let* ((narinfos (lookup-narinfos cache paths))
+ (hits (map narinfo-path narinfos))
+ (missing (lset-difference string=? paths hits))) ;XXX: perf
+ (loop rest missing (append narinfos result))))
+ (() ;that's it
+ result))))))
+
+(define (lookup-narinfo caches path)
+ "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
+was found."
+ (match (lookup-narinfos/diverse caches (list path))
+ ((answer) answer)
+ (_ #f)))
(define (remove-expired-cached-narinfos directory)
"Remove expired narinfo entries from DIRECTORY. The sole purpose of this
@@ -752,34 +778,34 @@ expected by the daemon."
(or (narinfo-size narinfo) 0)))
(define* (process-query command
- #:key cache-url acl)
+ #:key cache-urls acl)
"Reply to COMMAND, a query as written by the daemon to this process's
standard input. Use ACL as the access-control list against which to check
authorized substitutes."
(define (valid? obj)
- (and (narinfo? obj) (valid-narinfo? obj acl)))
+ (valid-narinfo? obj acl))
(match (string-tokenize command)
(("have" paths ..1)
- ;; Return the subset of PATHS available in CACHE-URL.
- (let ((substitutable (lookup-narinfos cache-url paths)))
+ ;; Return the subset of PATHS available in CACHE-URLS.
+ (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
(for-each (lambda (narinfo)
(format #t "~a~%" (narinfo-path narinfo)))
(filter valid? substitutable))
(newline)))
(("info" paths ..1)
- ;; Reply info about PATHS if it's in CACHE-URL.
- (let ((substitutable (lookup-narinfos cache-url paths)))
+ ;; Reply info about PATHS if it's in CACHE-URLS.
+ (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
(for-each display-narinfo-data (filter valid? substitutable))
(newline)))
(wtf
(error "unknown `--query' command" wtf))))
(define* (process-substitution store-item destination
- #:key cache-url acl)
- "Substitute STORE-ITEM (a store file name) from CACHE-URL, and write it to
+ #:key cache-urls acl)
+ "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL."
- (let* ((narinfo (lookup-narinfo cache-url store-item))
+ (let* ((narinfo (lookup-narinfo cache-urls store-item))
(uri (narinfo-uri narinfo)))
;; Make sure it is signed and everything.
(assert-valid-narinfo narinfo acl)
@@ -876,21 +902,16 @@ found."
b
first)))
-(define %cache-url
+(define %cache-urls
(match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client
(find-daemon-option "substitute-urls")) ;admin
string-tokenize)
- ((url)
- url)
- ((head tail ..1)
- ;; Currently we don't handle multiple substitute URLs.
- (warning (_ "these substitute URLs will not be used:~{ ~a~}~%")
- tail)
- head)
+ ((urls ...)
+ urls)
(#f
;; This can only happen when this script is not invoked by the
;; daemon.
- "http://hydra.gnu.org")))
+ '("http://hydra.gnu.org"))))
(define (guix-substitute . args)
"Implement the build daemon's substituter protocol."
@@ -901,20 +922,8 @@ found."
;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
;; when we know we cannot substitute, but we must emit a newline on stdout
;; when everything is alright.
- (let ((uri (string->uri %cache-url)))
- (case (uri-scheme uri)
- ((http)
- ;; Exit gracefully if there's no network access.
- (let ((host (uri-host uri)))
- (catch 'getaddrinfo-error
- (lambda ()
- (getaddrinfo host))
- (lambda (key error)
- (warning (_ "failed to look up host '~a' (~a), \
-substituter disabled~%")
- host (gai-strerror error))
- (exit 0)))))
- (else #t)))
+ (when (null? %cache-urls)
+ (exit 0))
;; Say hello (see above.)
(newline)
@@ -929,13 +938,13 @@ substituter disabled~%")
(or (eof-object? command)
(begin
(process-query command
- #:cache-url %cache-url
+ #:cache-urls %cache-urls
#:acl acl)
(loop (read-line)))))))
(("--substitute" store-path destination)
;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
(process-substitution store-path destination
- #:cache-url %cache-url
+ #:cache-urls %cache-urls
#:acl (current-acl)))
(("--version")
(show-version-and-exit "guix substitute"))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index b5da57a9ce..d847c75444 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -25,6 +25,7 @@
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (guix monads)
+ #:use-module (guix records)
#:use-module (guix profiles)
#:use-module (guix scripts)
#:use-module (guix scripts build)
@@ -41,6 +42,8 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (guix-system
@@ -186,6 +189,39 @@ the ownership of '~a' may be incorrect!~%")
;;;
+;;; Boot parameters
+;;;
+
+(define-record-type* <boot-parameters>
+ boot-parameters make-boot-parameters boot-parameters?
+ (label boot-parameters-label)
+ (root-device boot-parameters-root-device)
+ (kernel boot-parameters-kernel)
+ (kernel-arguments boot-parameters-kernel-arguments))
+
+(define (read-boot-parameters port)
+ "Read boot parameters from PORT and return the corresponding
+<boot-parameters> object or #f if the format is unrecognized."
+ (match (read port)
+ (('boot-parameters ('version 0)
+ ('label label) ('root-device root)
+ ('kernel linux)
+ rest ...)
+ (boot-parameters
+ (label label)
+ (root-device root)
+ (kernel linux)
+ (kernel-arguments
+ (match (assq 'kernel-arguments rest)
+ ((_ args) args)
+ (#f '()))))) ;the old format
+ (x ;unsupported format
+ (warning (_ "unrecognized boot parameters for '~a'~%")
+ system)
+ #f)))
+
+
+;;;
;;; Reconfiguration.
;;;
@@ -247,30 +283,22 @@ it atomically, and then run OS's activation script."
"Return a list of 'menu-entry' for the generations of PROFILE."
(define (system->grub-entry system number time)
(unless-file-not-found
- (call-with-input-file (string-append system "/parameters")
- (lambda (port)
- (match (read port)
- (('boot-parameters ('version 0)
- ('label label) ('root-device root)
- ('kernel linux)
- rest ...)
- (menu-entry
- (label (string-append label " (#"
- (number->string number) ", "
- (seconds->string time) ")"))
- (linux linux)
- (linux-arguments
- (cons* (string-append "--root=" root)
- #~(string-append "--system=" #$system)
- #~(string-append "--load=" #$system "/boot")
- (match (assq 'kernel-arguments rest)
- ((_ args) args)
- (#f '())))) ;old format
- (initrd #~(string-append #$system "/initrd"))))
- (_ ;unsupported format
- (warning (_ "unrecognized boot parameters for '~a'~%")
- system)
- #f))))))
+ (let ((file (string-append system "/parameters")))
+ (match (call-with-input-file file read-boot-parameters)
+ (($ <boot-parameters> label root kernel kernel-arguments)
+ (menu-entry
+ (label (string-append label " (#"
+ (number->string number) ", "
+ (seconds->string time) ")"))
+ (linux kernel)
+ (linux-arguments
+ (cons* (string-append "--root=" root)
+ #~(string-append "--system=" #$system)
+ #~(string-append "--load=" #$system "/boot")
+ kernel-arguments))
+ (initrd #~(string-append #$system "/initrd"))))
+ (#f ;invalid format
+ #f)))))
(let* ((numbers (generation-numbers profile))
(systems (map (cut generation-file-name profile <>)
@@ -327,6 +355,48 @@ list of services."
;;;
+;;; Generations.
+;;;
+
+(define* (display-system-generation number
+ #:optional (profile %system-profile))
+ "Display a summary of system generation NUMBER in a human-readable format."
+ (unless (zero? number)
+ (let* ((generation (generation-file-name profile number))
+ (param-file (string-append generation "/parameters"))
+ (params (call-with-input-file param-file read-boot-parameters)))
+ (display-generation profile number)
+ (format #t (_ " file name: ~a~%") generation)
+ (format #t (_ " canonical file name: ~a~%") (readlink* generation))
+ (match params
+ (($ <boot-parameters> label root kernel)
+ ;; TRANSLATORS: Please preserve the two-space indentation.
+ (format #t (_ " label: ~a~%") label)
+ (format #t (_ " root device: ~a~%") root)
+ (format #t (_ " kernel: ~a~%") kernel))
+ (_
+ #f)))))
+
+(define* (list-generations pattern #:optional (profile %system-profile))
+ "Display in a human-readable format all the system generations matching
+PATTERN, a string. When PATTERN is #f, display all the system generations."
+ (cond ((not (file-exists? profile)) ; XXX: race condition
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
+ ((string-null? pattern)
+ (for-each display-system-generation (profile-generations profile)))
+ ((matching-generations pattern profile)
+ =>
+ (lambda (numbers)
+ (if (null-list? numbers)
+ (exit 1)
+ (leave-on-EPIPE
+ (for-each display-system-generation numbers)))))
+ (else
+ (leave (_ "invalid syntax: ~a~%") pattern))))
+
+
+;;;
;;; Action.
;;;
@@ -442,7 +512,7 @@ building anything."
;;;
(define (show-help)
- (display (_ "Usage: guix system [OPTION] ACTION FILE
+ (display (_ "Usage: guix system [OPTION] ACTION [FILE]
Build the operating system declared in FILE according to ACTION.\n"))
(newline)
(display (_ "The valid values for ACTION are:\n"))
@@ -450,6 +520,8 @@ Build the operating system declared in FILE according to ACTION.\n"))
(display (_ "\
reconfigure switch to a new operating system configuration\n"))
(display (_ "\
+ list-generations list the system generations\n"))
+ (display (_ "\
build build the operating system without installing anything\n"))
(display (_ "\
vm build a virtual machine image that shares the host's store\n"))
@@ -488,19 +560,6 @@ Build the operating system declared in FILE according to ACTION.\n"))
(newline)
(show-bug-report-information))
-(define (specification->file-system-mapping spec writable?)
- "Read the SPEC and return the corresponding <file-system-mapping>."
- (let ((index (string-index spec #\=)))
- (if index
- (file-system-mapping
- (source (substring spec 0 index))
- (target (substring spec (+ 1 index)))
- (writable? writable?))
- (file-system-mapping
- (source spec)
- (target spec)
- (writable? writable?)))))
-
(define %options
;; Specifications of the command-line options.
(cons* (option '(#\h "help") #f #f
@@ -563,6 +622,71 @@ Build the operating system declared in FILE according to ACTION.\n"))
;;; Entry point.
;;;
+(define (process-action action args opts)
+ "Process ACTION, a sub-command, with the arguments are listed in ARGS.
+ACTION must be one of the sub-commands that takes an operating system
+declaration as an argument (a file name.) OPTS is the raw alist of options
+resulting from command-line parsing."
+ (let* ((file (match args
+ (() #f)
+ ((x . _) x)))
+ (system (assoc-ref opts 'system))
+ (os (if file
+ (load* file %user-module
+ #:on-error (assoc-ref opts 'on-error))
+ (leave (_ "no configuration file specified~%"))))
+
+ (dry? (assoc-ref opts 'dry-run?))
+ (grub? (assoc-ref opts 'install-grub?))
+ (target (match args
+ ((first second) second)
+ (_ #f)))
+ (device (and grub?
+ (grub-configuration-device
+ (operating-system-bootloader os)))))
+
+ (with-store store
+ (set-build-options-from-command-line store opts)
+
+ (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (case action
+ ((extension-graph)
+ (export-extension-graph os (current-output-port)))
+ ((dmd-graph)
+ (export-dmd-graph os (current-output-port)))
+ (else
+ (perform-action action os
+ #:dry-run? dry?
+ #:derivations-only? (assoc-ref opts
+ 'derivations-only?)
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:image-size (assoc-ref opts 'image-size)
+ #:full-boot? (assoc-ref opts 'full-boot?)
+ #:mappings (filter-map (match-lambda
+ (('file-system-mapping . m)
+ m)
+ (_ #f))
+ opts)
+ #:grub? grub?
+ #:target target #:device device))))
+ #:system system))))
+
+(define (process-command command args opts)
+ "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its
+argument list and OPTS is the option alist."
+ (case command
+ ((list-generations)
+ ;; List generations. No need to connect to the daemon, etc.
+ (let ((pattern (match args
+ (() "")
+ ((pattern) pattern)
+ (x (leave (_ "wrong number of arguments~%"))))))
+ (list-generations pattern)))
+ (else
+ (process-action command args opts))))
+
(define (guix-system . args)
(define (parse-sub-command arg result)
;; Parse sub-command ARG and augment RESULT accordingly.
@@ -571,7 +695,7 @@ Build the operating system declared in FILE according to ACTION.\n"))
(let ((action (string->symbol arg)))
(case action
((build vm vm-image disk-image reconfigure init
- extension-graph dmd-graph)
+ extension-graph dmd-graph list-generations)
(alist-cons 'action action result))
(else (leave (_ "~a: unknown action~%") action))))))
@@ -613,49 +737,7 @@ Build the operating system declared in FILE according to ACTION.\n"))
#:argument-handler
parse-sub-command))
(args (option-arguments opts))
- (file (first args))
- (action (assoc-ref opts 'action))
- (system (assoc-ref opts 'system))
- (os (if file
- (load* file %user-module
- #:on-error (assoc-ref opts 'on-error))
- (leave (_ "no configuration file specified~%"))))
-
- (dry? (assoc-ref opts 'dry-run?))
- (grub? (assoc-ref opts 'install-grub?))
- (target (match args
- ((first second) second)
- (_ #f)))
- (device (and grub?
- (grub-configuration-device
- (operating-system-bootloader os))))
-
- (store (open-connection)))
- (set-build-options-from-command-line store opts)
-
- (run-with-store store
- (mbegin %store-monad
- (set-guile-for-build (default-guile))
- (case action
- ((extension-graph)
- (export-extension-graph os (current-output-port)))
- ((dmd-graph)
- (export-dmd-graph os (current-output-port)))
- (else
- (perform-action action os
- #:dry-run? dry?
- #:derivations-only? (assoc-ref opts
- 'derivations-only?)
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:image-size (assoc-ref opts 'image-size)
- #:full-boot? (assoc-ref opts 'full-boot?)
- #:mappings (filter-map (match-lambda
- (('file-system-mapping . m)
- m)
- (_ #f))
- opts)
- #:grub? grub?
- #:target target #:device device))))
- #:system system))))
+ (command (assoc-ref opts 'action)))
+ (process-command command args opts))))
;;; system.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index c4e3573711..8413d1f452 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -501,11 +501,11 @@ encoding conversion errors."
(build-cores (current-processor-count))
(use-substitutes? #t)
- ;; Client-provided substitute URLs. For
- ;; unprivileged clients, these are considered
- ;; "untrusted"; for "trusted" users, they override
- ;; the daemon's settings.
- (substitute-urls %default-substitute-urls))
+ ;; Client-provided substitute URLs. If it is #f,
+ ;; the daemon's settings are used. Otherwise, it
+ ;; overrides the daemons settings; see 'guix
+ ;; substitute'.
+ (substitute-urls #f))
;; Must be called after `open-connection'.
(define socket
@@ -533,7 +533,10 @@ encoding conversion errors."
(let ((pairs `(,@(if timeout
`(("build-timeout" . ,(number->string timeout)))
'())
- ("substitute-urls" . ,(string-join substitute-urls)))))
+ ,@(if substitute-urls
+ `(("substitute-urls"
+ . ,(string-join substitute-urls)))
+ '()))))
(send (string-pairs pairs))))
(let loop ((done? (process-stderr server)))
(or done? (process-stderr server)))))
diff --git a/guix/ui.scm b/guix/ui.scm
index fb8121c213..312c2a01a1 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -34,6 +34,7 @@
#:use-module (guix serialization)
#:use-module ((guix build utils) #:select (mkdir-p))
#:use-module ((guix licenses) #:select (license? license-name))
+ #:use-module (gnu system file-systems)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
@@ -60,6 +61,7 @@
warn-about-load-error
show-version-and-exit
show-bug-report-information
+ make-regexp*
string->number*
size->number
show-derivation-outputs
@@ -72,7 +74,6 @@
read/eval
read/eval-package-expression
location->string
- switch-symlinks
config-directory
fill-paragraph
texi->plain-text
@@ -80,8 +81,15 @@
string->recutils
package->recutils
package-specification->name+version+output
+ specification->file-system-mapping
string->generations
string->duration
+ matching-generations
+ display-generation
+ display-profile-content
+ roll-back*
+ switch-to-generation*
+ delete-generation*
run-guix-command
run-guix
program-name
@@ -343,6 +351,16 @@ General help using GNU software: <http://www.gnu.org/gethelp/>"))
(list (strerror (car errno)) target)
(list errno)))))))
+(define (make-regexp* regexp . flags)
+ "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error
+nicely."
+ (catch 'regular-expression-syntax
+ (lambda ()
+ (apply make-regexp regexp flags))
+ (lambda (key proc message . rest)
+ (leave (_ "'~a' is not a valid regular expression: ~a~%")
+ regexp message))))
+
(define (string->number* str)
"Like `string->number', but error out with an error message on failure."
(or (string->number str)
@@ -710,13 +728,6 @@ replacement if PORT is not Unicode-capable."
(($ <location> file line column)
(format #f "~a:~a:~a" file line column))))
-(define (switch-symlinks link target)
- "Atomically switch LINK, a symbolic link, to point to TARGET. Works
-both when LINK already exists and when it does not."
- (let ((pivot (string-append link ".new")))
- (symlink target pivot)
- (rename-file pivot link)))
-
(define (config-directory)
"Return the name of the configuration directory, after making sure that it
exists. Honor the XDG specs,
@@ -946,6 +957,119 @@ following patterns: \"1d\", \"1w\", \"1m\"."
(hours->duration (* 24 30) match)))
(else #f)))
+(define* (matching-generations str profile
+ #:key (duration-relation <=))
+ "Return the list of available generations matching a pattern in STR. See
+'string->generations' and 'string->duration' for the list of valid patterns.
+When STR is a duration pattern, return all the generations whose ctime has
+DURATION-RELATION with the current time."
+ (define (valid-generations lst)
+ (define (valid-generation? n)
+ (any (cut = n <>) (generation-numbers profile)))
+
+ (fold-right (lambda (x acc)
+ (if (valid-generation? x)
+ (cons x acc)
+ acc))
+ '()
+ lst))
+
+ (define (filter-generations generations)
+ (match generations
+ (() '())
+ (('>= n)
+ (drop-while (cut > n <>)
+ (generation-numbers profile)))
+ (('<= n)
+ (valid-generations (iota n 1)))
+ ((lst ..1)
+ (valid-generations lst))
+ (_ #f)))
+
+ (define (filter-by-duration duration)
+ (define (time-at-midnight time)
+ ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
+ ;; hours to zeros.
+ (let ((d (time-utc->date time)))
+ (date->time-utc
+ (make-date 0 0 0 0
+ (date-day d) (date-month d)
+ (date-year d) (date-zone-offset d)))))
+
+ (define generation-ctime-alist
+ (map (lambda (number)
+ (cons number
+ (time-second
+ (time-at-midnight
+ (generation-time profile number)))))
+ (generation-numbers profile)))
+
+ (match duration
+ (#f #f)
+ (res
+ (let ((s (time-second
+ (subtract-duration (time-at-midnight (current-time))
+ duration))))
+ (delete #f (map (lambda (x)
+ (and (duration-relation s (cdr x))
+ (first x)))
+ generation-ctime-alist))))))
+
+ (cond ((string->generations str)
+ =>
+ filter-generations)
+ ((string->duration str)
+ =>
+ filter-by-duration)
+ (else #f)))
+
+(define (display-generation profile number)
+ "Display a one-line summary of generation NUMBER of PROFILE."
+ (unless (zero? number)
+ (let ((header (format #f (_ "Generation ~a\t~a") number
+ (date->string
+ (time-utc->date
+ (generation-time profile number))
+ "~b ~d ~Y ~T")))
+ (current (generation-number profile)))
+ (if (= number current)
+ (format #t (_ "~a\t(current)~%") header)
+ (format #t "~a~%" header)))))
+
+(define (display-profile-content profile number)
+ "Display the packages in PROFILE, generation NUMBER, in a human-readable
+way."
+ (for-each (match-lambda
+ (($ <manifest-entry> name version output location _)
+ (format #t " ~a\t~a\t~a\t~a~%"
+ name version output location)))
+
+ ;; Show most recently installed packages last.
+ (reverse
+ (manifest-entries
+ (profile-manifest (generation-file-name profile number))))))
+
+(define (display-generation-change previous current)
+ (format #t (_ "switched from generation ~a to ~a~%") previous current))
+
+(define (roll-back* store profile)
+ "Like 'roll-back', but display what is happening."
+ (call-with-values
+ (lambda ()
+ (roll-back store profile))
+ display-generation-change))
+
+(define (switch-to-generation* profile number)
+ "Like 'switch-generation', but display what is happening."
+ (let ((previous (switch-to-generation profile number)))
+ (display-generation-change previous number)))
+
+(define (delete-generation* store profile generation)
+ "Like 'delete-generation', but display what is going on."
+ (format #t (_ "deleting ~a~%")
+ (generation-file-name profile generation))
+ (delete-generation store profile generation))
+
(define* (package-specification->name+version+output spec
#:optional (output "out"))
"Parse package specification SPEC and return three value: the specified
@@ -966,6 +1090,23 @@ optionally contain a version number and an output name, as in these examples:
(package-name->name+version name)))
(values name version sub-drv)))
+(define (specification->file-system-mapping spec writable?)
+ "Read the SPEC and return the corresponding <file-system-mapping>. SPEC is
+a string of the form \"SOURCE\" or \"SOURCE=TARGET\". The former specifies
+that SOURCE from the host should be mounted at SOURCE in the other system.
+The latter format specifies that SOURCE from the host should be mounted at
+TARGET in the other system."
+ (let ((index (string-index spec #\=)))
+ (if index
+ (file-system-mapping
+ (source (substring spec 0 index))
+ (target (substring spec (+ 1 index)))
+ (writable? writable?))
+ (file-system-mapping
+ (source spec)
+ (target spec)
+ (writable? writable?)))))
+
;;;
;;; Command-line option processing.
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 9300113ac6..219ae0568c 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -45,6 +46,7 @@
upstream-updater
upstream-updater?
upstream-updater-name
+ upstream-updater-description
upstream-updater-predicate
upstream-updater-latest
@@ -109,18 +111,19 @@ correspond to the same version."
;;; Auto-update.
;;;
-(define-record-type <upstream-updater>
- (upstream-updater name pred latest)
+(define-record-type* <upstream-updater>
+ upstream-updater make-upstream-updater
upstream-updater?
- (name upstream-updater-name)
- (pred upstream-updater-predicate)
- (latest upstream-updater-latest))
+ (name upstream-updater-name)
+ (description upstream-updater-description)
+ (pred upstream-updater-predicate)
+ (latest upstream-updater-latest))
(define (lookup-updater package updaters)
"Return an updater among UPDATERS that matches PACKAGE, or #f if none of
them matches."
(any (match-lambda
- (($ <upstream-updater> _ pred latest)
+ (($ <upstream-updater> _ _ pred latest)
(and (pred package) latest)))
updaters))
diff --git a/guix/utils.scm b/guix/utils.scm
index 190b787185..1542e86f7a 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -74,6 +74,7 @@
arguments-from-environment-variable
file-extension
file-sans-extension
+ switch-symlinks
call-with-temporary-output-file
call-with-temporary-directory
with-atomic-file-output
@@ -82,6 +83,7 @@
fold-tree-leaves
split
cache-directory
+ readlink*
filtered-port
compressed-port
@@ -556,6 +558,13 @@ minor version numbers from version-string."
(substring file 0 dot)
file)))
+(define (switch-symlinks link target)
+ "Atomically switch LINK, a symbolic link, to point to TARGET. Works
+both when LINK already exists and when it does not."
+ (let ((pivot (string-append link ".new")))
+ (symlink target pivot)
+ (rename-file pivot link)))
+
(define* (string-replace-substring str substr replacement
#:optional
(start 0)
@@ -710,6 +719,33 @@ elements after E."
(and=> (getenv "HOME")
(cut string-append <> "/.cache/guix"))))
+(define (readlink* file)
+ "Call 'readlink' until the result is not a symlink."
+ (define %max-symlink-depth 50)
+
+ (let loop ((file file)
+ (depth 0))
+ (define (absolute target)
+ (if (absolute-file-name? target)
+ target
+ (string-append (dirname file) "/" target)))
+
+ (if (>= depth %max-symlink-depth)
+ file
+ (call-with-values
+ (lambda ()
+ (catch 'system-error
+ (lambda ()
+ (values #t (readlink file)))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (if (or (= errno EINVAL))
+ (values #f file)
+ (apply throw args))))))
+ (lambda (success? target)
+ (if success?
+ (loop (absolute target) (+ depth 1))
+ file))))))
;;;
;;; Source location.
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 0c4e4f8443..41cf9ee0f4 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -12,6 +12,7 @@ guix/scripts/package.scm
guix/scripts/gc.scm
guix/scripts/hash.scm
guix/scripts/import.scm
+guix/scripts/import/cran.scm
guix/scripts/import/elpa.scm
guix/scripts/pull.scm
guix/scripts/substitute.scm
@@ -23,6 +24,7 @@ guix/scripts/edit.scm
guix/scripts/size.scm
guix/scripts/graph.scm
guix/scripts/challenge.scm
+guix/gnu-maintenance.scm
guix/upstream.scm
guix/ui.scm
guix/http-client.scm
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index a72ce0911d..f7fb3c5b64 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -167,6 +167,33 @@ guix build -e "(begin
guix build -e '#~(mkdir #$output)' -d
guix build -e '#~(mkdir #$output)' -d | grep 'gexp\.drv'
+# Building from a package file.
+cat > "$module_dir/package.scm"<<EOF
+(use-modules (gnu))
+(use-package-modules bootstrap)
+
+%bootstrap-guile
+EOF
+guix build --file="$module_dir/package.scm"
+
+# Building from a monadic procedure file.
+cat > "$module_dir/proc.scm"<<EOF
+(use-modules (guix gexp))
+(lambda ()
+ (gexp->derivation "test"
+ (gexp (mkdir (ungexp output)))))
+EOF
+guix build --file="$module_dir/proc.scm" --dry-run
+
+# Building from a gexp file.
+cat > "$module_dir/gexp.scm"<<EOF
+(use-modules (guix gexp))
+
+(gexp (mkdir (ungexp output)))
+EOF
+guix build --file="$module_dir/gexp.scm" -d
+guix build --file="$module_dir/gexp.scm" -d | grep 'gexp\.drv'
+
# Using 'GUIX_BUILD_OPTIONS'.
GUIX_BUILD_OPTIONS="--dry-run"
export GUIX_BUILD_OPTIONS
diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh
new file mode 100644
index 0000000000..141fd160a7
--- /dev/null
+++ b/tests/guix-environment-container.sh
@@ -0,0 +1,76 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2015 David Thompson <davet@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/>.
+
+#
+# Test 'guix environment'.
+#
+
+set -e
+
+guix environment --version
+
+tmpdir="t-guix-environment-$$"
+trap 'rm -r "$tmpdir"' EXIT
+
+mkdir "$tmpdir"
+
+# Make sure the exit value is preserved.
+if guix environment --container --ad-hoc --bootstrap guile-bootstrap \
+ -- guile -c '(exit 42)'
+then
+ false
+else
+ test $? = 42
+fi
+
+# Make sure that the right directories are mapped.
+mount_test_code="
+(use-modules (ice-9 rdelim)
+ (ice-9 match)
+ (srfi srfi-1))
+
+(define mappings
+ (filter-map (lambda (line)
+ (match (string-split line #\space)
+ ;; Empty line.
+ ((\"\") #f)
+ ;; Ignore these types of file systems.
+ ((_ _ (or \"tmpfs\" \"proc\" \"sysfs\" \"devtmpfs\"
+ \"devpts\" \"cgroup\" \"mqueue\") _ _ _)
+ #f)
+ ((_ mount _ _ _ _)
+ mount)))
+ (string-split (call-with-input-file \"/proc/mounts\" read-string)
+ #\newline)))
+
+(for-each (lambda (mount)
+ (display mount)
+ (newline))
+ mappings)"
+
+guix environment --container --ad-hoc --bootstrap guile-bootstrap \
+ -- guile -c "$mount_test_code" > $tmpdir/mounts
+
+cat "$tmpdir/mounts"
+test `wc -l < $tmpdir/mounts` -eq 3
+
+grep -e "$PWD$" $tmpdir/mounts # current directory
+grep $(guix build guile-bootstrap) $tmpdir/mounts
+grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash
+
+rm $tmpdir/mounts
diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh
index f91c78a801..49b3b1ccc3 100644
--- a/tests/guix-environment.sh
+++ b/tests/guix-environment.sh
@@ -97,4 +97,18 @@ then
# Make sure the "debug" output is not listed.
if grep -E "$make_boot0_debug" "$tmpdir/a"; then false; else true; fi
+
+ # Compute the build environment for the initial GNU Make, but add in the
+ # bootstrap Guile as an ad-hoc addition.
+ guix environment -e '(@@ (gnu packages commencement) gnu-make-boot0)' \
+ --ad-hoc guile-bootstrap --no-substitutes --search-paths \
+ --pure > "$tmpdir/a"
+
+ # Make sure the bootstrap binaries are all listed where they belong.
+ cat $tmpdir/a
+ grep -E '^export PATH=.*-bootstrap-binaries-0/bin' "$tmpdir/a"
+ grep -E '^export PATH=.*-guile-bootstrap-2.0/bin' "$tmpdir/a"
+ grep -E '^export CPATH=.*-gcc-bootstrap-0/include' "$tmpdir/a"
+ grep -E '^export CPATH=.*-glibc-bootstrap-0/include' "$tmpdir/a"
+ grep -E '^export LIBRARY_PATH=.*-glibc-bootstrap-0/lib' "$tmpdir/a"
fi
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 85698127fa..9d907e7abf 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -167,8 +167,8 @@ a file for NARINFO."
(call-with-narinfo narinfo (lambda () body ...)))
;; Transmit these options to 'guix substitute'.
-(set! (@@ (guix scripts substitute) %cache-url)
- (getenv "GUIX_BINARY_SUBSTITUTE_URL"))
+(set! (@@ (guix scripts substitute) %cache-urls)
+ (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
(test-equal "query narinfo without signature"
"" ; not substitutable