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

Merge branch 'master' into dbus-update

Browse source
This commit is contained in:
宋文武 2015-10-30 20:50:26 +08:00
commit eed588d997
74 changed files with 2143 additions and 810 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

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

1
Makefile.am
View file

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

25
doc/contributing.texi
View file

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

2
doc/emacs.texi
View file

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

246
doc/guix.texi
View file

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

2
emacs/guix-base.el
View file

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

5
emacs/guix-command.el
View file

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

2
emacs/guix-devel.el
View file

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

4
emacs/guix-pcomplete.el
View file

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

2
gnu-system.am
View file

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

2
gnu/build/linux-container.scm
View file

@ -165,7 +165,7 @@ (define (namespaces->bit-mask namespaces)
"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)

2
gnu/packages/algebra.scm
View file

@ -26,6 +26,7 @@ (define-module (gnu packages algebra)
#: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 @@ (define-public pari-gp
"0k1qqagfl6zn7gvwmsqffj6g9yrzqvszwh2mblhmxpjlw1pigfh8"))))
(build-system gnu-build-system)
(inputs `(("gmp" ,gmp)
("libx11" ,libx11)
("perl" ,perl)
("readline" ,readline)))
(arguments

2
gnu/packages/avahi.scm
View file

@ -23,7 +23,7 @@ (define-module (gnu packages avahi)
#: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)

45
gnu/packages/backup.scm
View file

@ -30,9 +30,12 @@ (define-module (gnu packages backup)
#: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 @@ (define-public libarchive
(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 @@ (define-public attic
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+)))

77
gnu/packages/bioinformatics.scm
View file

@ -805,15 +805,16 @@ (define-public clustal-omega
(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 @@ (define-public python2-warpedlmm
(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 @@ (define-public pbtranscript-tofu
#:configure-flags '("--single-version-externally-managed"
"--record=pbtranscript-tofu.txt")
#:phases
(alist-cons-after
'unpack 'enter-directory-and-clean-up
(modify-phases %standard-phases
(add-after 'unpack 'enter-directory
(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)))
#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 @@ (define-public subread
(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

4
gnu/packages/cyrus-sasl.scm
View file

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

22
gnu/packages/databases.scm
View file

@ -53,6 +53,28 @@ (define-module (gnu packages databases)
#: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")

8
gnu/packages/emacs.scm
View file

@ -316,7 +316,7 @@ (define-public git-modes
(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 @@ (define-public magit
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 @@ (define-public magit
(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 @@ (define-public magit-svn
(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)

4
gnu/packages/fish.scm
View file

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

4
gnu/packages/freeipmi.scm
View file

@ -27,14 +27,14 @@ (define-module (gnu packages freeipmi)
(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)))

8
gnu/packages/gcc.scm
View file

@ -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 @@ (define-module (gnu packages gcc)
#: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 @@ (define-public gcj
("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 @@ (define-public gcj
(ice-9 regex)
(srfi srfi-1)
(srfi srfi-26))
#:test-target "check-target-libjava"
,@(package-arguments gcc))
((#:tests? _) #t)
((#:configure-flags flags)
`(let ((ecj (assoc-ref %build-inputs "ecj-bootstrap")))
`("--enable-java-home"

46
gnu/packages/gdbm.scm
View file

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

16
gnu/packages/grub.scm
View file

@ -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 @@ (define-module (gnu packages grub)
#: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,8 +87,9 @@ (define-public grub
(build-system gnu-build-system)
(arguments
'(#:configure-flags '("--disable-werror")
#:phases (alist-cons-before
'patch-source-shebangs 'patch-stuff
#: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")))
@ -96,18 +100,22 @@ (define-public grub
;; TODO: Re-enable this test when we have Parted.
(substitute* "tests/partmap_test.in"
(("set -e") "exit 77")))
%standard-phases)))
(("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.

8
gnu/packages/guile.scm
View file

@ -38,7 +38,7 @@ (define-module (gnu packages guile)
#: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 @@ (define-public guile-2.0/fixed
(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.

59
gnu/packages/haskell.scm
View file

@ -865,14 +865,6 @@ (define-public ghc-sdl
(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 @@ (define-public ghc-sdl-mixer
`(#: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 @@ (define-public ghc-sdl-image
`(#: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 @@ (define-public ghc-glut
(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 @@ (define-public ghc-old-time
(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 @@ (define-public ghc-x11
"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 @@ (define-public ghc-unix-time
"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 @@ (define-public ghc-network
(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

18
gnu/packages/java.scm
View file

@ -576,7 +576,7 @@ (define-public icedtea6
(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 @@ (define-public icedtea7
version ".tar.xz"))
(sha256
(base32
"0s107vi1530a5dyxacysc4m64zshgg2d3xpndsc0ws99wz0zmr6c"))
"0xi0w8gpxx3r68hyi7fb991hxb3rqfp7895nfsl4wj3sa1f5ds5y"))
(modules '((guix build utils)))
(snippet
'(substitute* "Makefile.in"
@ -728,24 +728,24 @@ (define-public icedtea7
(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")))))))

8
gnu/packages/linux.scm
View file

@ -210,7 +210,7 @@ (define (lookup file)
#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 @@ (define-public linux-libre
(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 @@ (define-public linux-libre
(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 @@ (define-public linux-libre
(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)

2
gnu/packages/mail.scm
View file

@ -36,7 +36,6 @@ (define-module (gnu packages mail)
#: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 @@ (define-module (gnu packages mail)
#: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)

2
gnu/packages/man.scm
View file

@ -24,9 +24,9 @@ (define-module (gnu packages man)
#: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)

4
gnu/packages/maths.scm
View file

@ -1461,7 +1461,7 @@ (define-public muparser
(define-public openblas
(package
(name "openblas")
(version "0.2.14")
(version "0.2.15")
(source
(origin
(method url-fetch)
@ -1470,7 +1470,7 @@ (define-public openblas
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"0av3pd96j8rx5i65f652xv9wqfkaqn0w4ma1gvbyz73i6j2hi9db"))))
"1k5f6vjlk54qlplk5m7xkbaw6g2y7dl50lwwdv6xsbcsgsbxfcpy"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ;no "check" target

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

@ -23,9 +23,12 @@ (define-module (gnu packages package-management)
#: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 @@ (define-module (gnu packages package-management)
#: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 @@ (define-public stow
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+)))

32
gnu/packages/password-utils.scm
View file

@ -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 @@ (define-module (gnu packages password-utils)
#: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 @@ (define-public shroud
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+)))

31
gnu/packages/patches/xfce4-session-fix-xflock4.patch Normal file
View file

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

35
gnu/packages/pcre.scm
View file

@ -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 @@ (define-public pcre
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/")))

2
gnu/packages/pulseaudio.scm
View file

@ -27,7 +27,7 @@ (define-module (gnu packages pulseaudio)
#: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)

97
gnu/packages/python.scm
View file

@ -39,8 +39,8 @@ (define-module (gnu packages python)
#: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 @@ (define-public python-libarchive-c
(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))

3
gnu/packages/ruby.scm
View file

@ -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 @@ (define-module (gnu packages ruby)
#: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)

2
gnu/packages/sawfish.scm
View file

@ -22,7 +22,7 @@ (define-module (gnu packages sawfish)
#: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)

4
gnu/packages/scheme.scm
View file

@ -334,7 +334,7 @@ (define-public scheme48
(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 @@ (define-public racket
version "/racket/racket-" version "-src-unix.tgz")))
(sha256
(base32
"0xfsfdqkngz0xw2lqmc7bsznwx25cw91l9fjhp7abrr05m96j0h9"))))
"0555j63k7fs10iv0icmivlxpzgp6s7gwcbfddmbwxlf2rk80qhq0"))))
(build-system gnu-build-system)
(arguments
'(#:phases

80
gnu/packages/video.scm
View file

@ -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,20 +413,10 @@ (define-public ffmpeg
("yasm" ,yasm)))
(arguments
`(#:test-target "fate"
#:phases
(modify-phases %standard-phases
(replace
'configure
;; configure does not work followed by "SHELL=..." and
;; "CONFIG_SHELL=..."; set environment variables instead
(lambda* (#:key outputs configure-flags #:allow-other-keys)
(let ((out (assoc-ref outputs "out")))
(substitute* "configure"
(("#! /bin/sh") (string-append "#!" (which "bash"))))
(setenv "SHELL" (which "bash"))
(setenv "CONFIG_SHELL" (which "bash"))
#:configure-flags
;; possible additional inputs:
;; --enable-avisynth enable reading of AviSynth script files [no]
;; --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]
@ -433,7 +424,8 @@ (define-public ffmpeg
;; 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-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]
@ -441,34 +433,37 @@ (define-public ffmpeg
;; --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-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-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-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-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-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-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-avresample"
"--enable-gpl" ; enable optional gpl licensed parts
"--enable-shared"
"--enable-fontconfig"
@ -500,7 +495,26 @@ (define-public ffmpeg
"--disable-mips32r2"
"--disable-mipsdspr1"
"--disable-mipsdspr2"
"--disable-mipsfpu")))))
"--disable-mipsfpu")
#:phases
(modify-phases %standard-phases
(replace
'configure
;; configure does not work followed by "SHELL=..." and
;; "CONFIG_SHELL=..."; set environment variables instead
(lambda* (#:key outputs configure-flags #:allow-other-keys)
(let ((out (assoc-ref outputs "out")))
(substitute* "configure"
(("#! /bin/sh") (string-append "#!" (which "bash"))))
(setenv "SHELL" (which "bash"))
(setenv "CONFIG_SHELL" (which "bash"))
(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 @@ (define-public libvpx
(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 @@ (define-public youtube-dl
version ".tar.gz"))
(sha256
(base32
"001a4md0yl3zx129mksmwc85grss67r3c9rynvranf9vlpv202vn"))))
"1q9srq08vb2yzl81hmjrgqwajckq52fhh9ag2ppbbxjibf91w5gs"))))
(build-system python-build-system)
(inputs `(("setuptools" ,python-setuptools)))
(home-page "http://youtube-dl.org")

5
gnu/packages/xfce.scm
View file

@ -423,7 +423,10 @@ (define-public xfce4-session
"/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

42
gnu/packages/xorg.scm
View file

@ -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 @@ (define-public perl-x11-protocol
;; 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"))))

101
gnu/services.scm
View file

@ -48,6 +48,7 @@ (define-module (gnu services)
service-kind
service-parameters
modify-services
service-back-edges
fold-services
@ -62,6 +63,7 @@ (define-module (gnu services)
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 @@ (define-record-type <service>
(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 @@ (define (directory-union name things)
(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 @@ (define (service-activations)
(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 @@ (define (service-activations)
(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 @@ (define %activation-service
;; 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)))

22
gnu/services/base.scm
View file

@ -57,6 +57,7 @@ (define-module (gnu services base)
mingetty-configuration
mingetty-configuration?
mingetty-service
mingetty-service-type
%nscd-default-caches
%nscd-default-configuration
@ -74,6 +75,7 @@ (define-module (gnu services base)
guix-configuration
guix-configuration?
guix-service
guix-service-type
%base-services))
@ -142,6 +144,18 @@ (define (file-system->dmd-service-name 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 @@ (define file-system-service-type
(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 @@ (define-record-type* <guix-configuration>
(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 @@ (define (guix-dmd-service config)
"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 @@ (define (guix-dmd-service config)
#$@(if use-substitutes?
'()
'("--no-substitutes"))
"--substitute-urls" #$(string-join substitute-urls)
#$@extra-options)
;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the

6
gnu/services/desktop.scm
View file

@ -34,6 +34,8 @@ (define-module (gnu services desktop)
#: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 @@ (define %desktop-services
;; 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)

55
gnu/services/xorg.scm
View file

@ -32,16 +32,21 @@ (define-module (gnu services xorg)
#: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 @@ (define* (slim-service #:key (slim slim)
(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

22
gnu/system.scm
View file

@ -195,19 +195,16 @@ (define (device-mappings fs)
(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))))
(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))
(map (lambda (md)
(symbol-append 'device-mapping-
(string->symbol (mapped-device-target md))))
(device-mappings fs))))
eq?))))
(map file-system-service file-systems))
(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 @@ (define known-fs
;; 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?)

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

@ -99,9 +99,8 @@ (define-record-type* <file-system> file-system
(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

49
gnu/system/grub.scm
View file

@ -30,6 +30,7 @@ (define-module (gnu system grub)
#: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 @@ (define* (grub-background-image config #:key (width 640) (height 480))
(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 @@ (define (theme-colors type)
(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,6 +199,7 @@ (define (theme-colors type)
set menu_color_normal=cyan/blue
set menu_color_highlight=white/blue
fi~%"
#$setup-gfxterm-body
#$grub #$grub
#$image
#$(theme-colors grub-theme-color-normal)
@ -206,6 +217,11 @@ (define* (grub-configuration-file config entries
"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 @@ (define entry->gexp
(($ <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)

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

@ -178,11 +178,13 @@ (define (file-system-type-predicate type)
(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
'())

3
gnu/system/linux.scm
View file

@ -182,8 +182,7 @@ (define* (base-pam-services #:key allow-empty-passwords?)
;; 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

9
guix/build/haskell-build-system.scm
View file

@ -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 @@ (define* (configure #:key outputs inputs tests? (configure-flags '())
'("--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)

8
guix/gnu-maintenance.scm
View file

@ -413,8 +413,10 @@ (define (non-emacs-gnu-package? package)
(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

8
guix/import/cran.scm
View file

@ -236,8 +236,10 @@ (define (cran-package? package)
(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

8
guix/import/elpa.scm
View file

@ -272,8 +272,10 @@ (define (package-from-gnu.org? package)
(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

80
guix/profiles.scm
View file

@ -84,13 +84,17 @@ (define-module (guix profiles)
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 @@ (define (generation-time profile number)
(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

30
guix/scripts/build.scm
View file

@ -185,8 +185,7 @@ (define (set-build-options-from-command-line store opts)
#:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes? (assoc-ref opts 'substitutes?)
#:substitute-urls (or (assoc-ref opts 'substitute-urls)
%default-substitute-urls)
#: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 @@ (define (show-help)
(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 @@ (define %options
(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,13 +427,8 @@ (define (options/resolve-packages store opts)
(define system
(or (assoc-ref opts 'system) (%current-system)))
(map (match-lambda
(('argument . (? string? spec))
(if (store-path? spec)
`(argument . ,spec)
`(argument . ,(specification->package spec))))
(('expression . str)
(match (read/eval str)
(define (object->argument obj)
(match obj
((? package? p)
`(argument . ,p))
((? procedure? proc)
@ -445,6 +445,16 @@ (define system
(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)
(object->argument (read/eval str)))
(opt opt))
opts))
@ -501,6 +511,8 @@ (define (guix-build . args)
(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

2
guix/scripts/challenge.scm
View file

@ -125,9 +125,7 @@ (define (select-reference item narinfos urls)
servers))
;; No 'assert-valid-narinfo' on purpose.
(narinfos -> (fold (lambda (narinfo vhash)
(if narinfo
(vhash-cons (narinfo-path narinfo) narinfo
vhash)
vhash))
vlist-null
remote)))

269
guix/scripts/environment.scm
View file

@ -25,13 +25,19 @@ (define-module (guix scripts environment)
#: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 @@ (define %precious-variables
(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 @@ (define (show-help)
--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 @@ (define %default-options
(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 @@ (define %options
(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 @@ (define %options
(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 @@ (define same-key? (cut eq? key <>))
(_ 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."
(compact
(append-map (match-lambda
(('package . (? string? spec))
(('package mode (? string? spec))
(let-values (((package output)
(specification->package+output spec)))
`((package ,package ,output))))
(('expression . str)
(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)
`(package ,package ,output))
(list mode package output))
(package-outputs package)))))
(('load . file)
(('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))
(list mode package output))
(package-outputs package))))
(opt (list opt)))
opts))
(_ '(#f)))
opts)))
(define (build-inputs inputs opts)
"Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION
@ -231,10 +293,135 @@ (define (build-inputs inputs 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.
@ -250,18 +437,21 @@ (define (guix-environment . args)
(with-error-handling
(let* ((opts (parse-args args))
(pure? (assoc-ref opts 'pure))
(ad-hoc? (assoc-ref opts 'ad-hoc?))
(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 (pick-all (options/resolve-packages opts) 'package))
(inputs (if ad-hoc?
(packages (options/resolve-packages opts))
(mappings (pick-all opts 'file-system-mapping))
(inputs (delete-duplicates
(append-map (match-lambda
((package output)
(('ad-hoc-package package output)
(package+propagated-inputs package
output)))
packages)
(append-map (compose bag-transitive-inputs
package->bag
first)
output))
(('package package output)
(bag-transitive-inputs
(package->bag package))))
packages)))
(paths (delete-duplicates
(cons $PATH
@ -274,26 +464,45 @@ (define (guix-environment . args)
eq?)))
(with-store store
(run-with-store store
(mlet %store-monad ((inputs (lower-inputs
(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))))
#: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?)
;; 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
(create-environment inputs paths pure?)
(return
(exit
(status:exit-val
(apply system* command)))))))))))))
(exit/status
(launch-environment command inputs paths pure?))))))))))))

208
guix/scripts/package.scm
View file

@ -48,11 +48,7 @@ (define-module (guix scripts package)
#: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 @@ (define (user-friendly-profile 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 @@ (define (package->manifest-entry* package output)
(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 @@ (define absolute
(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 @@ (define (build-and-use-profile manifest)
;; 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 @@ (define (build-and-use-profile manifest)
(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 @@ (define (process-query opts)
(('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 @@ (define (list-generation number)
#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 @@ (define (list-generation number)
#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 @@ (define (list-generation number)
#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)))

1
guix/scripts/pull.scm
View file

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

32
guix/scripts/refresh.scm
View file

@ -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 @@ (define %options
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 @@ (define (show-help)
-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 @@ (define (lookup-updater name)
(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 @@ (define (parse-options)
(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

3
guix/scripts/size.scm
View file

@ -252,8 +252,7 @@ (define %options
(show-version-and-exit "guix size")))))
(define %default-options
`((system . ,(%current-system))
(substitute-urls . ,%default-substitute-urls)))
`((system . ,(%current-system))))
;;;

111
guix/scripts/substitute.scm
View file

@ -72,6 +72,7 @@ (define-module (guix scripts substitute)
assert-valid-narinfo
lookup-narinfos
lookup-narinfos/diverse
read-narinfo
write-narinfo
guix-substitute))
@ -474,12 +475,13 @@ (define (narinfo-request cache-url path)
".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 @@ (define (http-multiple-get base-url requests proc)
((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 @@ (define update-progress!
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 @@ (define (handle-narinfo-response request response port)
(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 @@ (define (handle-narinfo-response request response port)
(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 @@ (define cache-info
((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 @@ (define (lookup-narinfos cache paths)
(let-values (((valid? value)
(cached-narinfo cache path)))
(if valid?
(if value
(values (cons value cached) missing)
(values cached missing))
(values cached (cons path missing)))))
'()
'()
@ -606,11 +611,32 @@ (define (lookup-narinfos cache paths)
(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 @@ (define (display-narinfo-data narinfo)
(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 @@ (define-syntax-rule (or* a b)
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 @@ (define (guix-substitute . args)
;; 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 @@ (define (guix-substitute . args)
(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"))

230
guix/scripts/system.scm
View file

@ -25,6 +25,7 @@ (define-module (guix scripts system)
#: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 @@ (define-module (guix scripts system)
#: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
@ -184,6 +187,39 @@ (define (maybe-copy to-copy)
(mwhen grub?
(install-grub* grub.cfg device target)))))
;;;
;;; 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 @@ (define* (previous-grub-entries #:optional (profile %system-profile))
"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 ...)
(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 linux)
(linux kernel)
(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
kernel-arguments))
(initrd #~(string-append #$system "/initrd"))))
(_ ;unsupported format
(warning (_ "unrecognized boot parameters for '~a'~%")
system)
#f))))))
(#f ;invalid format
#f)))))
(let* ((numbers (generation-numbers profile))
(systems (map (cut generation-file-name profile <>)
@ -325,6 +353,48 @@ (define (dmd-service-node-type services)
(label dmd-service-node-label)
(edges (lift1 (dmd-service-back-edges services) %store-monad))))
;;;
;;; 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,13 +512,15 @@ (define (export-dmd-graph os port)
;;;
(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"))
(newline)
(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 (_ "\
@ -488,19 +560,6 @@ (define (show-help)
(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 @@ (define %default-options
;;; 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 @@ (define (parse-sub-command arg result)
(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 @@ (define (fail)
#: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

15
guix/store.scm
View file

@ -501,11 +501,11 @@ (define* (set-build-options server
(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 @@ (define socket
(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)))))

157
guix/ui.scm
View file

@ -34,6 +34,7 @@ (define-module (guix ui)
#: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 @@ (define-module (guix ui)
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 @@ (define-module (guix ui)
read/eval
read/eval-package-expression
location->string
switch-symlinks
config-directory
fill-paragraph
texi->plain-text
@ -80,8 +81,15 @@ (define-module (guix ui)
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 @@ (define (show-bug-report-information)
(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 @@ (define (location->string loc)
(($ <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 @@ (define (hours->duration hours match)
(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 @@ (define* (package-specification->name+version+output spec
(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.

9
guix/upstream.scm
View file

@ -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 @@ (define-module (guix upstream)
upstream-updater
upstream-updater?
upstream-updater-name
upstream-updater-description
upstream-updater-predicate
upstream-updater-latest
@ -109,10 +111,11 @@ (define (release>? r1 r2)
;;; 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)
(description upstream-updater-description)
(pred upstream-updater-predicate)
(latest upstream-updater-latest))
@ -120,7 +123,7 @@ (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))

36
guix/utils.scm
View file

@ -74,6 +74,7 @@ (define-module (guix utils)
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 @@ (define-module (guix utils)
fold-tree-leaves
split
cache-directory
readlink*
filtered-port
compressed-port
@ -556,6 +558,13 @@ (define (file-sans-extension file)
(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 @@ (define (cache-directory)
(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.

2
po/guix/POTFILES.in
View file

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

27
tests/guix-build.sh
View file

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

76
tests/guix-environment-container.sh Normal file
View file

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

14
tests/guix-environment.sh
View file

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

4
tests/substitute.scm
View file

@ -167,8 +167,8 @@ (define-syntax-rule (with-narinfo narinfo body ...)
(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