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

Merge branch 'master' into core-updates

This commit is contained in:
Mark H Weaver 2014-09-08 11:00:06 -04:00
parent 1145938496 4a4cbd0bdd
commit e759c0a38c
63 changed files with 5973 additions and 563 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitignore vendored
View File

@ -105,3 +105,8 @@ GTAGS
/nix-setuid-helper
/nix/scripts/guix-authenticate
/nix/scripts/offload
/emacs/Makefile.in
/emacs/Makefile
/emacs/guix-autoloads.el
/emacs/guix-helper.scm
/emacs/guix-init.el

7
HACKING
View File

@ -89,6 +89,13 @@ in the form of patches as produced by ‘git format-patch’ sent to
guix-devel@gnu.org. Please write commit logs in the [[http://www.gnu.org/prep/standards/html_node/Change-Logs.html#Change-Logs][GNU ChangeLog
format]]; you can check the commit history for examples.
Before submitting a patch that adds or modifies a package definition, please
run ‘guix lint PACKAGE’, where PACKAGE is the name of the new or modified
package, and fix any errors it reports. In addition, please make sure the
package builds on your platform, using ‘guix build’. You may also want to
check that dependent package (if applicable) are not affected by the change;
‘guix refresh --list-dependent PACKAGE’ will help you do that.
When posting a patch to the mailing list, use "[PATCH] ..." as a subject. You
may use your email client or the ‘git send-mail’ command.

13
Makefile.am
View File

@ -62,17 +62,14 @@ MODULES = \
guix/build/git.scm \
guix/build/gnu-build-system.scm \
guix/build/gnu-dist.scm \
guix/build/linux-initrd.scm \
guix/build/perl-build-system.scm \
guix/build/python-build-system.scm \
guix/build/store-copy.scm \
guix/build/utils.scm \
guix/build/union.scm \
guix/build/pull.scm \
guix/build/rpath.scm \
guix/build/svn.scm \
guix/build/vm.scm \
guix/build/install.scm \
guix/build/activation.scm \
guix/build/syscalls.scm \
guix/build/emacs-utils.scm \
guix/packages.scm \
@ -89,6 +86,7 @@ MODULES = \
guix/scripts/authenticate.scm \
guix/scripts/refresh.scm \
guix/scripts/system.scm \
guix/scripts/lint.scm \
guix.scm \
$(GNU_SYSTEM_MODULES)
@ -159,7 +157,8 @@ SCM_TESTS = \
tests/nar.scm \
tests/union.scm \
tests/profiles.scm \
tests/syscalls.scm
tests/syscalls.scm \
tests/lint.scm
SH_TESTS = \
tests/guix-build.sh \
@ -279,6 +278,10 @@ AM_DISTCHECK_CONFIGURE_FLAGS = \
--with-nix-prefix="$(NIX_PREFIX)" \
--enable-daemon
dist_emacsui_DATA = emacs/guix-main.scm
nodist_emacsui_DATA = emacs/guix-helper.scm
include emacs.am
dist-hook: sync-descriptions gen-ChangeLog assert-no-store-file-names
distcheck-hook: assert-binaries-available assert-final-inputs-self-contained

16
README
View File

@ -52,19 +52,23 @@ To do so:
- Install the dependencies (see 'Requirements' above) and build tools using
Guix:
guix package --install={autoconf,automake,bzip2,gcc-toolchain,gettext,guile,libgcrypt,pkg-config,sqlite}
guix package --install autoconf automake bzip2 gcc-toolchain gettext \
guile libgcrypt pkg-config sqlite
- set the environment variables that Guix recommends you to set during the
- Set the environment variables that Guix recommends you to set during the
package installation process:
ACLOCAL_PATH, CPATH, LIBRARY_PATH, PKG_CONFIG_PATH
- set the PATH environment variable to refer to the profile:
- Set the PATH environment variable to refer to the profile:
PATH=$HOME/.guix-profile/bin:$PATH
- re-run the configure script passing it the option
`--with-libgcrypt-prefix=$HOME/.guix-profile/'
- Re-run the 'configure' script passing it the option
'--with-libgcrypt-prefix=$HOME/.guix-profile/', as well as
'--localstatedir=/somewhere', where '/somewhere' is the 'localstatedir'
value of the currently installed Guix (failing to do that would lead the
new Guix to consider the store to be empty!).
- run "make" and "make install"
- Run "make", "make check", and "make install".
* How It Works

1
THANKS
View File

@ -7,6 +7,7 @@ suggestions, bug reports, patches, internationalization, or general
infrastructure help:
Lluís Batlle i Rossell <viric@viric.name>
Federico Beffa <beffa@ieee.org>
Marek Benc <merkur32@gmail.com>
Carlos Carleos <carleos@uniovi.es>
Felipe Castro <fefcas@gmail.com>

5
config-daemon.ac
View File

@ -78,10 +78,13 @@ if test "x$guix_build_daemon" = "xyes"; then
dnl lutimes and lchown: used when canonicalizing store items.
dnl posix_fallocate: used when extracting archives.
dnl vfork: to speed up spawning of helper programs.
dnl `--> now disabled because of unpredictable behavior:
dnl see <http://lists.gnu.org/archive/html/guix-devel/2014-05/msg00036.html>
dnl and Nix commit f794465c (Nov. 2012).
dnl sched_setaffinity: to improve RPC locality.
dnl statvfs: to detect disk-full conditions.
dnl strsignal: for error reporting.
AC_CHECK_FUNCS([lutimes lchown posix_fallocate vfork sched_setaffinity \
AC_CHECK_FUNCS([lutimes lchown posix_fallocate sched_setaffinity \
statvfs nanosleep strsignal])
dnl Check whether the store optimiser can optimise symlinks.

7
configure.ac
View File

@ -174,4 +174,11 @@ AC_CONFIG_FILES([scripts/guix], [chmod +x scripts/guix])
AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
AC_CONFIG_FILES([test-env], [chmod +x test-env])
dnl Emacs interface.
AM_PATH_LISPDIR
emacsuidir="${guilemoduledir}/guix/emacs"
AC_SUBST([emacsuidir])
AC_CONFIG_FILES([emacs/guix-init.el
emacs/guix-helper.scm])
AC_OUTPUT

321
doc/emacs.texi Normal file
View File

@ -0,0 +1,321 @@
@node Emacs Interface
@section Emacs Interface
@cindex emacs
GNU Guix comes with a visual user interface for GNU@tie{}Emacs, known
as ``guix.el''. It can be used for routine package management tasks,
pretty much like the @command{guix package} command (@pxref{Invoking
guix package}). Specifically, ``guix.el'' makes it easy to:
@itemize
@item browse and display packages and generations;
@item search, install, upgrade and remove packages;
@item display packages from previous generations;
@item do some other useful things.
@end itemize
@menu
* Initial Setup: emacs Initial Setup. Preparing @file{~/.emacs}.
* Usage: emacs Usage. Using the interface.
* Configuration: emacs Configuration. Configuring the interface.
@end menu
@node emacs Initial Setup
@subsection Initial Setup
To be able to use ``guix.el'', you need to install the following
packages:
@itemize
@item
@uref{http://www.gnu.org/software/emacs/, GNU Emacs}, version 24.3 or
later;
@item
@uref{http://nongnu.org/geiser/, Geiser}, version 0.3 or later: it is
used for interacting with the Guile process.
@end itemize
When it is done, add the following into your init file (@pxref{Init
File,,, emacs, The Emacs Editor}):
@example
(require 'guix-init nil t)
@end example
However there is a chance that @code{load-path} of your Emacs does not
contain a directory with ``guix.el'' (usually it is
@file{/usr/share/emacs/site-lisp/}). In that case you need to add it
before requiring (@pxref{Lisp Libraries,,, emacs, The Emacs Editor}):
@example
(add-to-list 'load-path "/path/to/directory-with-guix.el")
(require 'guix-init)
@end example
Do not worry about the efficiency of that @code{require} thing. It will
not load the whole ``guix.el'' package, it will just autoload the main
interactive commands (@pxref{Autoload,,, elisp, Emacs Lisp}).
@node emacs Usage
@subsection Usage
Once ``guix.el'' has been successfully configured, you should be able to
use commands for displaying packages and generations. This information
can be displayed in a ``list'' or ``info'' buffer.
@menu
* Commands: emacs Commands. @kbd{M-x guix-@dots{}}
* General information: emacs General info. Common for both interfaces.
* ``List'' buffer: emacs List buffer. List-like interface.
* ``Info'' buffer: emacs Info buffer. Help-like interface.
@end menu
@node emacs Commands
@subsubsection Commands
You may use the following commands to display packages and generations:
@table @kbd
@item M-x guix-all-available-packages
@itemx M-x guix-newest-available-packages
Display all/newest available packages.
@item M-x guix-installed-packages
Display all packages installed in the current profile.
@item M-x guix-obsolete-packages
Display obsolete packages (the packages that are installed in the
current profile but cannot be found among available packages).
@item M-x guix-search-by-name
Display package(s) with the specified name.
@item M-x guix-search-by-regexp
Search for packages by a specified regexp. By default ``name'',
``synopsis'' and ``description'' of the packages will be searched. This
can be changed by modifying @code{guix-search-params} variable.
@item M-x guix-generations
List generations for the current profile. With numeric prefix, show so
many last generations.
@end table
It is possible to change the currently used profile with
@kbd{M-x@tie{}guix-set-current-profile}. This has the same effect as
specifying @code{--profile} option for @command{guix package}
(@pxref{Invoking guix package}).
@node emacs General info
@subsubsection General information
The following keys are available for both ``list'' and ``info'' types of
buffers:
@table @kbd
@item l
@itemx r
Go backward/forward by the history of the displayed results (this
history is similar to the history of the Emacs @code{help-mode} or
@code{Info-mode}).
@item g
Revert current buffer: update information about the displayed
packages/generations and redisplay it.
@item R
Redisplay current buffer (without updating information).
@item C-c C-z
Go to the Guix REPL (@pxref{The REPL,,, geiser, Geiser User Manual}).
@item h
@itemx ?
Describe current mode to see all available bindings.
@end table
@emph{Hint:} If you need several ``list'' or ``info'' buffers, you can
simlpy @kbd{M-x clone-buffer} them, and each buffer will have its own
history.
@emph{Warning:} Name/version pairs cannot be used to identify packages
(because a name is not necessarily unique), so ``guix.el'' uses special
identifiers that live only during a guile session, so if the Guix REPL
was restarted, you may want to revert ``list'' buffer (by pressing
@kbd{g}).
@node emacs List buffer
@subsubsection ``List'' buffer
An interface of a ``list'' buffer is similar to the interface provided
by ``package.el'' (@pxref{Package Menu,,, emacs, The Emacs Editor}).
Default key bindings available for both ``package-list'' and
``generation-list'' buffers:
@table @kbd
@item m
Mark the current entry.
@item M
Mark all entries.
@item u
Unmark the current entry.
@item @key{DEL}
Unmark backward.
@item U
Unmark all entries.
@item S
Sort entries by a specified column.
@end table
A ``package-list'' buffer additionally provides the following bindings:
@table @kbd
@item @key{RET}
Describe marked packages (display available information in a
``package-info'' buffer).
@item i
Mark a package for installation (with prefix, prompt for output(s) to
install).
@item d
Mark a package for deletion.
@item ^
Mark a package for upgrading.
@item x
Execute actions on marked packages.
@end table
A ``generation-list'' buffer additionally provides the following
bindings:
@table @kbd
@item @key{RET}
List packages installed in the current generation.
@item i
Describe marked generations (display available information in a
``generation-info'' buffer).
@end table
@node emacs Info buffer
@subsubsection ``Info'' buffer
The interface of an ``info'' buffer is similar to the interface of
@code{help-mode} (@pxref{Help Mode,,, emacs, The Emacs Editor}).
``Info'' buffer contains some buttons (as usual you may use @key{TAB} /
@kbd{S-@key{TAB}} to move between buttons---@pxref{Mouse References,,,
emacs, The Emacs Editor}) which can be used to:
@itemize @bullet
@item (in a ``package-info'' buffer)
@itemize @minus
@item install/remove a package;
@item jump to a package location;
@item browse home page of a package;
@item describe packages from ``Inputs'' fields.
@end itemize
@item (in a ``generation-info'' buffer)
@itemize @minus
@item remove a generation;
@item list packages installed in a generation;
@item jump to a generation directory.
@end itemize
@end itemize
@node emacs Configuration
@subsection Configuration
There are many variables you can modify to change the appearance or
behavior of Emacs user interface. Some of these variables are described
in this section. Also you can use Custom Interface (@pxref{Easy
Customization,,, emacs, The Emacs Editor}) to explore/set variables (not
all) and faces.
@menu
* Guile and Build Options: emacs Build Options. Specifying how packages are built.
* Keymaps: emacs Keymaps. Configuring key bindings.
* Appearance: emacs Appearance. Settings for visual appearance.
@end menu
@node emacs Build Options
@subsubsection Guile and Build Options
@table @code
@item guix-guile-program
If you have some special needs for starting a Guile process, you may set
this variable, for example:
@example
(setq guix-guile-program '("/bin/guile" "--no-auto-compile"))
@end example
@item guix-use-substitutes
Has the same meaning as @code{--no-substitutes} option (@pxref{Invoking
guix build}).
@item guix-dry-run
Has the same meaning as @code{--dry-run} option (@pxref{Invoking guix
build}).
@end table
@node emacs Keymaps
@subsubsection Keymaps
If you want to change default key bindings, use the following keymaps
(@pxref{Init Rebinding,,, emacs, The Emacs Editor}):
@table @code
@item guix-list-mode-map
Parent keymap with general keys for ``list'' buffers.
@item guix-package-list-mode-map
Keymap with specific keys for ``package-list'' buffers.
@item guix-generation-list-mode-map
Keymap with specific keys for ``generation-list'' buffers.
@item guix-info-mode-map
Parent keymap with general keys for ``info'' buffers.
@item guix-package-info-mode-map
Keymap with specific keys for ``package-info'' buffers.
@item guix-generation-info-mode-map
Keymap with specific keys for ``generation-info'' buffers.
@end table
@node emacs Appearance
@subsubsection Appearance
You can change almost any aspect of ``list'' / ``info'' buffers using
the following variables:
@table @code
@item guix-list-column-format
@itemx guix-list-column-titles
@itemx guix-list-column-value-methods
Specify the columns, their names, what and how is displayed in ``list''
buffers.
@item guix-info-displayed-params
@itemx guix-info-insert-methods
@itemx guix-info-ignore-empty-vals
@itemx guix-info-param-title-format
@itemx guix-info-multiline-prefix
@itemx guix-info-indent
@itemx guix-info-fill-column
@itemx guix-info-delimiter
Various settings for ``info'' buffers.
@end table

66
doc/guix.texi
View File

@ -506,14 +506,16 @@ Unless @code{--lose-logs} is used, all the build logs are kept in the
@var{localstatedir}. To save space, the daemon automatically compresses
them with bzip2 by default. This option disables that.
@item --disable-store-optimization
@item --disable-deduplication
@cindex deduplication
Disable automatic file ``deduplication'' in the store.
By default, files added to the store are automatically ``deduplicated'':
if a newly added file is identical as another one found in the store,
the daemon makes the new file a hard link to the other file. This
slightly increases the input/output load at the end of a build process.
This option disables this.
if a newly added file is identical to another one found in the store,
the daemon makes the new file a hard link to the other file. This can
noticeably reduce disk usage, at the expense of slightly increasde
input/output load at the end of a build process. This option disables
this optimization.
@item --gc-keep-outputs[=yes|no]
Tell whether the garbage collector (GC) must keep outputs of live
@ -579,6 +581,7 @@ management tools it provides.
@menu
* Features:: How Guix will make your life brighter.
* Invoking guix package:: Package installation, removal, etc.
* Emacs Interface:: Package management from Emacs.
* Substitutes:: Downloading pre-built binaries.
* Packages with Multiple Outputs:: Single source package, multiple outputs.
* Invoking guix gc:: Running the garbage collector.
@ -953,6 +956,8 @@ Finally, since @command{guix package} may actually start build
processes, it supports all the common build options that @command{guix
build} supports (@pxref{Invoking guix build, common build options}).
@include emacs.texi
@node Substitutes
@section Substitutes
@ -1457,7 +1462,10 @@ definitions like the one above may be automatically converted from the
Nixpkgs distribution using the @command{guix import} command.}, the
package may actually be built using the @code{guix build} command-line
tool (@pxref{Invoking guix build}). @xref{Packaging Guidelines}, for
more information on how to test package definitions.
more information on how to test package definitions, and
@ref{Invoking guix lint}, for information on how to check a definition
for style conformance.
Eventually, updating the package definition to a new upstream version
can be partly automated by the @command{guix refresh} command
@ -2270,6 +2278,22 @@ search path to be copied in the store, compiled, and made available in
the load path during the execution of @var{exp}---e.g., @code{((guix
build utils) (guix build gnu-build-system))}.
When @var{references-graphs} is true, it must be a list of tuples of one of the
following forms:
@example
(@var{file-name} @var{package})
(@var{file-name} @var{package} @var{output})
(@var{file-name} @var{derivation})
(@var{file-name} @var{derivation} @var{output})
(@var{file-name} @var{store-item})
@end example
The right-hand-side of each element of @var{references-graphs} is automatically made
an input of the build process of @var{exp}. In the build environment, each
@var{file-name} contains the reference graph of the corresponding item, in a simple
text format.
The other arguments are as for @code{derivation} (@pxref{Derivations}).
@end deffn
@ -2326,6 +2350,7 @@ programming interface of Guix in a convenient way.
* Invoking guix download:: Downloading a file and printing its hash.
* Invoking guix hash:: Computing the cryptographic hash of a file.
* Invoking guix refresh:: Updating package definitions.
* Invoking guix lint:: Finding errors in package definitions.
@end menu
@node Invoking guix build
@ -2703,6 +2728,29 @@ for in @code{$PATH}.
@end table
@node Invoking guix lint
@section Invoking @command{guix lint}
The @command{guix lint} is meant to help package developers avoid common
errors and use a consistent style. It runs a few checks on a given set of
packages in order to find common mistakes in their definitions.
The general syntax is:
@example
guix lint @var{options} @var{package}@dots{}
@end example
If no package is given on the command line, then all packages are checked.
The @var{options} may be zero or more of the following:
@table @code
@item --list-checkers
@itemx -l
List and describe all the available checkers that will be run on packages
and exit.
@end table
@c *********************************************************************
@node GNU Distribution
@ -2946,7 +2994,7 @@ more information, @pxref{Invoking guix system}. This command may trigger
downloads or builds of missing packages, which can take some time.
Once that command has completed---and hopefully succeeded!---you can
unmount @file{/mnt} and boot into the new system. Cross fingers, and
run @command{reboot} and boot into the new system. Cross fingers, and
join us on @code{#guix} on the Freenode IRC network or on
@file{guix-devel@@gnu.org} to share your experience---good or not so
good.
@ -3533,6 +3581,10 @@ system declaration like this:
#:extra-modules '("my.ko" "modules.ko")))
@end example
@noindent
Note that for the example above, the SRFI-26 module needs to be imported
(@pxref{SRFI-26,,, guile, GNU Guile Reference Manual}).
It also handles common use cases that involves using the system as a
QEMU guest, or as a ``live'' system whose root file system is volatile.

43
emacs.am Normal file
View File

@ -0,0 +1,43 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2014 Alex Kost <alezost@gmail.com>
#
# This file is part of GNU Guix.
#
# GNU Guix is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# GNU Guix is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
AUTOLOADS = emacs/guix-autoloads.el
ELFILES = \
emacs/guix-backend.el \
emacs/guix-base.el \
emacs/guix-history.el \
emacs/guix-info.el \
emacs/guix-list.el \
emacs/guix-utils.el \
emacs/guix.el
dist_lisp_DATA = \
$(ELFILES) \
$(AUTOLOADS)
nodist_lisp_DATA = \
emacs/guix-init.el
$(AUTOLOADS): $(ELFILES)
$(EMACS) --batch --eval \
"(let ((backup-inhibited t) \
(generated-autoload-file \
(expand-file-name \"$(AUTOLOADS)\" \"$(srcdir)\"))) \
(update-directory-autoloads \
(expand-file-name \"emacs\" \"$(srcdir)\")))"

301
emacs/guix-backend.el Normal file
View File

@ -0,0 +1,301 @@
;;; guix-backend.el --- Communication with Geiser
;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;; This file is part of GNU Guix.
;; GNU Guix is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Guix is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides the code for interacting with Guile using Geiser.
;; By default (if `guix-use-guile-server' is non-nil) 2 Geiser REPLs are
;; started. The main one (with "guile --listen" process) is used for
;; "interacting" with a user - for showing a progress of
;; installing/deleting Guix packages. The second (internal) REPL is
;; used for synchronous evaluating, e.g. when information about
;; packages/generations should be received for a list/info buffer.
;;
;; This "2 REPLs concept" makes it possible to have a running process of
;; installing/deleting packages and to continue to search/list/get info
;; about other packages at the same time. If you prefer to use a single
;; Guix REPL, do not try to receive any information while there is a
;; running code in the REPL (see
;; <https://github.com/jaor/geiser/issues/28>).
;;
;; If you need to use "guix.el" in another Emacs (i.e. when there is
;; a runnig "guile --listen..." REPL somewhere), you can either change
;; `guix-default-port' in that Emacs instance or set
;; `guix-use-guile-server' to t.
;;
;; Guix REPLs (unlike the usual Geiser REPLs) are not added to
;; `geiser-repl--repls' variable, and thus cannot be used for evaluating
;; while editing scm-files. The only purpose of Guix REPLs is to be an
;; intermediate between "Guix/Guile level" and "Emacs interface level".
;; That being said you can still want to use a Guix REPL while hacking
;; auxiliary scheme-files for "guix.el". You can just use "M-x
;; connect-to-guile" (connect to "localhost" and `guix-default-port') to
;; have a usual Geiser REPL with all stuff defined by "guix.el" package.
;;; Code:
(require 'geiser-mode)
(defvar guix-load-path
(file-name-directory (or load-file-name
(locate-library "guix")))
"Directory with scheme files for \"guix.el\" package.")
(defvar guix-helper-file
(expand-file-name "guix-helper.scm" guix-load-path)
"Auxiliary scheme file for loading.")
(defvar guix-guile-program (or geiser-guile-binary "guile")
"Name of the guile executable used for Guix REPL.
May be either a string (the name of the executable) or a list of
strings of the form:
(NAME . ARGS)
Where ARGS is a list of arguments to the guile program.")
;;; REPL
(defgroup guix-repl nil
"Settings for Guix REPLs."
:prefix "guix-repl-"
:group 'guix)
(defcustom guix-repl-startup-time 30000
"Time, in milliseconds, to wait for Guix REPL to startup.
Same as `geiser-repl-startup-time' but is used for Guix REPL.
If you have a slow system, try to increase this time."
:type 'integer
:group 'guix-repl)
(defcustom guix-repl-buffer-name "*Guix REPL*"
"Default name of a Geiser REPL buffer used for Guix."
:type 'string
:group 'guix-repl)
(defcustom guix-after-start-repl-hook ()
"Hook called after Guix REPL is started."
:type 'hook
:group 'guix-repl)
(defcustom guix-use-guile-server t
"If non-nil, start guile with '--listen' argument.
This allows to receive information about packages using an additional
REPL while some packages are being installed/removed in the main REPL."
:type 'boolean
:group 'guix-repl)
(defcustom guix-default-port 37246
"Default port used if `guix-use-guile-server' is non-nil."
:type 'integer
:group 'guix-repl)
(defvar guix-repl-buffer nil
"Main Geiser REPL buffer used for communicating with Guix.
This REPL is used for processing package actions and for
receiving information if `guix-use-guile-server' is nil.")
(defvar guix-internal-repl-buffer nil
"Additional Geiser REPL buffer used for communicating with Guix.
This REPL is used for receiving information only if
`guix-use-guile-server' is non-nil.")
(defvar guix-internal-repl-buffer-name "*Guix Internal REPL*"
"Default name of an internal Guix REPL buffer.")
(defun guix-get-guile-program (&optional internal)
"Return a value suitable for `geiser-guile-binary'."
(if (or internal
(not guix-use-guile-server))
guix-guile-program
(append (if (listp guix-guile-program)
guix-guile-program
(list guix-guile-program))
;; Guile understands "--listen=..." but not "--listen ..."
(list (concat "--listen="
(number-to-string guix-default-port))))))
(defun guix-start-process-maybe ()
"Start Geiser REPL configured for Guix if needed."
(guix-start-repl-maybe)
(if guix-use-guile-server
(guix-start-repl-maybe 'internal)
(setq guix-internal-repl-buffer guix-repl-buffer)))
(defun guix-start-repl-maybe (&optional internal)
"Start Guix REPL if needed.
If INTERNAL is non-nil, start an internal REPL."
(let* ((repl-var (guix-get-repl-buffer-variable internal))
(repl (symbol-value repl-var)))
(unless (and (buffer-live-p repl)
(get-buffer-process repl))
;; Kill REPL buffer with a dead process
(and (buffer-live-p repl) (kill-buffer repl))
(or internal
(message "Starting Geiser REPL for Guix ..."))
(let ((geiser-guile-binary (guix-get-guile-program internal))
(geiser-guile-init-file (or internal guix-helper-file))
(repl (get-buffer-create
(guix-get-repl-buffer-name internal))))
(condition-case err
(guix-start-repl repl
(and internal
(geiser-repl--read-address
"localhost" guix-default-port)))
(text-read-only
(error (concat "Couldn't start Guix REPL. Perhaps the port %s is busy.\n"
"See buffer '%s' for details")
guix-default-port (buffer-name repl))))
(set repl-var repl)
(unless internal
(message "Guix REPL has been started.")
(run-hooks 'guix-after-start-repl-hook))))))
(defun guix-start-repl (buffer &optional address)
"Start Guix REPL in BUFFER.
If ADDRESS is non-nil, connect to a remote guile process using
this address (it should be defined by
`geiser-repl--read-address')."
;; A mix of the code from `geiser-repl--start-repl' and
;; `geiser-repl--to-repl-buffer'.
(let ((impl 'guile)
(geiser-guile-load-path (list guix-load-path))
(geiser-repl-startup-time guix-repl-startup-time))
(with-current-buffer buffer
(geiser-repl-mode)
(geiser-impl--set-buffer-implementation impl)
(geiser-repl--autodoc-mode -1)
(goto-char (point-max))
(let* ((prompt-re (geiser-repl--prompt-regexp impl))
(deb-prompt-re (geiser-repl--debugger-prompt-regexp impl))
(prompt (geiser-con--combined-prompt prompt-re deb-prompt-re)))
(or prompt-re
(error "Oh no! Guix REPL in the buffer '%s' has not been started"
(buffer-name buffer)))
(geiser-repl--save-remote-data address)
(geiser-repl--start-scheme impl address prompt)
(geiser-repl--quit-setup)
(geiser-repl--history-setup)
(setq-local geiser-repl--repls (list buffer))
(geiser-repl--set-this-buffer-repl buffer)
(setq geiser-repl--connection
(geiser-con--make-connection
(get-buffer-process (current-buffer))
prompt-re
deb-prompt-re))
(geiser-repl--startup impl address)
(geiser-repl--autodoc-mode 1)
(geiser-company--setup geiser-repl-company-p)
(add-hook 'comint-output-filter-functions
'geiser-repl--output-filter
nil t)
(set-process-query-on-exit-flag
(get-buffer-process (current-buffer))
geiser-repl-query-on-kill-p)))))
(defun guix-get-repl-buffer (&optional internal)
"Return Guix REPL buffer; start REPL if needed.
If INTERNAL is non-nil, return an additional internal REPL."
(guix-start-process-maybe)
(let ((repl (symbol-value (guix-get-repl-buffer-variable internal))))
;; If a new Geiser REPL is started, `geiser-repl--repl' variable may
;; be set to the new value in a Guix REPL, so set it back to a
;; proper value here.
(with-current-buffer repl
(geiser-repl--set-this-buffer-repl repl))
repl))
(defun guix-get-repl-buffer-variable (&optional internal)
"Return the name of a variable with a REPL buffer."
(if internal
'guix-internal-repl-buffer
'guix-repl-buffer))
(defun guix-get-repl-buffer-name (&optional internal)
"Return the name of a REPL buffer."
(if internal
guix-internal-repl-buffer-name
guix-repl-buffer-name))
(defun guix-switch-to-repl (&optional internal)
"Switch to Guix REPL.
If INTERNAL is non-nil (interactively with prefix), switch to the
additional internal REPL if it exists."
(interactive "P")
(geiser-repl--switch-to-buffer (guix-get-repl-buffer internal)))
;;; Evaluating expressions
(defun guix-make-guile-expression (fun &rest args)
"Return string containing a guile expression for calling FUN with ARGS."
(format "(%S %s)" fun
(mapconcat
(lambda (arg)
(cond
((null arg) "'()")
((or (eq arg t)
;; An ugly hack to separate 'false' from nil
(equal arg 'f)
(keywordp arg))
(concat "#" (prin1-to-string arg t)))
((or (symbolp arg) (listp arg))
(concat "'" (prin1-to-string arg)))
(t (prin1-to-string arg))))
args
" ")))
(defun guix-eval (str &optional wrap)
"Evaluate guile expression STR.
If WRAP is non-nil, wrap STR into (begin ...) form.
Return a list of strings with result values of evaluation."
(with-current-buffer (guix-get-repl-buffer 'internal)
(let* ((wrapped (if wrap (geiser-debug--wrap-region str) str))
(code `(:eval (:scm ,wrapped)))
(ret (geiser-eval--send/wait code)))
(if (geiser-eval--retort-error ret)
(error "Error in evaluating guile expression: %s"
(geiser-eval--retort-output ret))
(cdr (assq 'result ret))))))
(defun guix-eval-read (str &optional wrap)
"Evaluate guile expression STR.
For the meaning of WRAP, see `guix-eval'.
Return elisp expression of the first result value of evaluation."
;; Parsing scheme code with elisp `read' is probably not the best idea.
(read (replace-regexp-in-string
"#f\\|#<unspecified>" "nil"
(replace-regexp-in-string
"#t" "t" (car (guix-eval str wrap))))))
(defun guix-eval-in-repl (str)
"Switch to Guix REPL and evaluate STR with guile expression there."
(let ((repl (guix-get-repl-buffer)))
(with-current-buffer repl
(delete-region (geiser-repl--last-prompt-end) (point-max))
(goto-char (point-max))
(insert str)
(geiser-repl--send-input))
(geiser-repl--switch-to-buffer repl)))
(provide 'guix-backend)
;;; guix-backend.el ends here

607
emacs/guix-base.el Normal file
View File

@ -0,0 +1,607 @@
;;; guix-base.el --- Common definitions
;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;; This file is part of GNU Guix.
;; GNU Guix is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Guix is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides some base and common definitions for guix.el
;; package.
;; List and info buffers have many common patterns that are defined
;; using `guix-define-buffer-type' macro from this file.
;;; Code:
(require 'cl-lib)
(require 'guix-backend)
(require 'guix-utils)
;;; Profiles
(defvar guix-user-profile
(expand-file-name "~/.guix-profile")
"User profile.")
(defvar guix-default-profile
(concat (or (getenv "NIX_STATE_DIR") "/var/guix")
"/profiles/per-user/"
(getenv "USER")
"/guix-profile")
"Default Guix profile.")
(defvar guix-current-profile guix-default-profile
"Current profile.")
(defun guix-set-current-profile (path)
"Set `guix-current-profile' to PATH.
Interactively, prompt for PATH. With prefix, use
`guix-default-profile'."
(interactive
(list (if current-prefix-arg
guix-default-profile
(read-file-name "Set profile: "
(file-name-directory guix-current-profile)))))
(let ((path (directory-file-name (expand-file-name path))))
(setq guix-current-profile
(if (string= path guix-user-profile)
guix-default-profile
path))
(message "Current profile has been set to '%s'."
guix-current-profile)))
;;; Parameters of the entries
(defvar guix-param-titles
'((package
(id . "ID")
(name . "Name")
(version . "Version")
(license . "License")
(synopsis . "Synopsis")
(description . "Description")
(home-url . "Home page")
(outputs . "Outputs")
(inputs . "Inputs")
(native-inputs . "Native inputs")
(propagated-inputs . "Propagated inputs")
(location . "Location")
(installed . "Installed"))
(installed
(path . "Installed path")
(dependencies . "Dependencies")
(output . "Output"))
(generation
(id . "ID")
(number . "Number")
(prev-number . "Previous number")
(path . "Path")
(time . "Time")))
"List for defining titles of entry parameters.
Titles are used for displaying information about entries.
Each element of the list has a form:
(ENTRY-TYPE . ((PARAM . TITLE) ...))")
(defun guix-get-param-title (entry-type param)
"Return title of an ENTRY-TYPE entry parameter PARAM."
(or (guix-get-key-val guix-param-titles
entry-type param)
(prog1 (symbol-name param)
(message "Couldn't find title for '%S %S'."
entry-type param))))
(defun guix-get-name-spec (name version &optional output)
"Return Guix package specification by its NAME, VERSION and OUTPUT."
(concat name "-" version
(when output (concat ":" output))))
(defun guix-get-full-name (entry &optional output)
"Return name specification of the package ENTRY and OUTPUT."
(guix-get-name-spec (guix-get-key-val entry 'name)
(guix-get-key-val entry 'version)
output))
(defun guix-get-installed-outputs (entry)
"Return list of installed outputs for the package ENTRY."
(mapcar (lambda (installed-entry)
(guix-get-key-val installed-entry 'output))
(guix-get-key-val entry 'installed)))
(defun guix-get-entry-by-id (id entries)
"Return entry from ENTRIES by entry ID."
(cl-find-if (lambda (entry)
(equal id (guix-get-key-val entry 'id)))
entries))
;;; Location of the packages
(defvar guix-directory nil
"Default Guix directory.
If it is not set by a user, it is set after starting Guile REPL.
This directory is used to define location of the packages.")
(defun guix-set-directory ()
"Set `guix-directory' if needed."
(or guix-directory
(setq guix-directory
(guix-eval-read "%guix-dir"))))
(add-hook 'guix-after-start-repl-hook 'guix-set-directory)
(defun guix-find-location (location)
"Go to LOCATION of a package.
LOCATION is a string of the form:
\"PATH:LINE:COLUMN\"
If PATH is relative, it is considered to be relative to
`guix-directory'."
(cl-multiple-value-bind (path line col)
(split-string location ":")
(let ((file (expand-file-name path guix-directory))
(line (string-to-number line))
(col (string-to-number col)))
(find-file file)
(goto-char (point-min))
(forward-line (- line 1))
(move-to-column col)
(recenter 1))))
;;; Common definitions for buffer types
(defvar-local guix-entries nil
"List of the currently displayed entries.
Each element of the list is alist with entry info of the
following form:
((PARAM . VAL) ...)
PARAM is a name of the entry parameter.
VAL is a value of this parameter.")
(put 'guix-entries 'permanent-local t)
(defvar-local guix-search-type nil
"Type of the current search.")
(put 'guix-search-type 'permanent-local t)
(defvar-local guix-search-vals nil
"Values of the current search.")
(put 'guix-search-vals 'permanent-local t)
(defsubst guix-set-vars (entries search-type search-vals)
(setq guix-entries entries
guix-search-type search-type
guix-search-vals search-vals))
(defmacro guix-define-buffer-type (buf-type entry-type &rest args)
"Define common stuff for BUF-TYPE buffers for displaying entries.
ENTRY-TYPE is a type of displayed entries (see
`guix-get-entries').
In the text below TYPE means ENTRY-TYPE-BUF-TYPE.
This macro defines `guix-TYPE-mode', a custom group, several user
variables and the following functions:
- `guix-TYPE-get-params-for-receiving'
- `guix-TYPE-revert'
- `guix-TYPE-redisplay'
- `guix-TYPE-make-history-item'
- `guix-TYPE-set'
- `guix-TYPE-show'
- `guix-TYPE-get-show'
The following stuff should be defined outside this macro:
- `guix-BUF-TYPE-mode' - parent mode for the defined mode.
- `guix-BUF-TYPE-insert-entries' - function for inserting
entries in the current buffer; it is called with 2 arguments:
entries of the form of `guix-entries' and ENTRY-TYPE.
- `guix-BUF-TYPE-get-displayed-params' - function returning a
list of parameters displayed in the current buffer; it is
called with ENTRY-TYPE as argument.
- `guix-TYPE-mode-initialize' (optional) - function for
additional mode settings; it is called without arguments.
Remaining argument (ARGS) should have a form [KEYWORD VALUE] ... The
following keywords are available:
- `:required' - default value for the defined
`guix-TYPE-required-params' variable.
- `:history-size' - default value for the defined
`guix-TYPE-history-size' variable.
- `:revert' - default value for the defined
`guix-TYPE-revert-no-confirm' variable."
(let* ((entry-type-str (symbol-name entry-type))
(buf-type-str (symbol-name buf-type))
(Entry-type-str (capitalize entry-type-str))
(Buf-type-str (capitalize buf-type-str))
(entry-str (concat entry-type-str " entries"))
(buf-str (concat buf-type-str " buffer"))
(prefix (concat "guix-" entry-type-str "-" buf-type-str))
(group (intern prefix))
(mode-map-str (concat prefix "-mode-map"))
(mode-map (intern mode-map-str))
(parent-mode (intern (concat "guix-" buf-type-str "-mode")))
(mode (intern (concat prefix "-mode")))
(mode-init-fun (intern (concat prefix "-mode-initialize")))
(buf-name-var (intern (concat prefix "-buffer-name")))
(revert-var (intern (concat prefix "-revert-no-confirm")))
(revert-fun (intern (concat prefix "-revert")))
(redisplay-fun (intern (concat prefix "-redisplay")))
(history-var (intern (concat prefix "-history-size")))
(history-fun (intern (concat prefix "-make-history-item")))
(params-var (intern (concat prefix "-required-params")))
(params-fun (intern (concat prefix "-get-params-for-receiving")))
(set-fun (intern (concat prefix "-set")))
(show-fun (intern (concat prefix "-show")))
(get-show-fun (intern (concat prefix "-get-show")))
(revert-val nil)
(history-val 20)
(params-val '(id)))
;; Process the keyword args.
(while (keywordp (car args))
(pcase (pop args)
(`:required (setq params-val (pop args)))
(`:history-size (setq history-val (pop args)))
(`:revert (setq revert-val (pop args)))
(_ (pop args))))
`(progn
(defgroup ,group nil
,(concat Buf-type-str " buffer with " entry-str ".")
:prefix ,(concat prefix "-")
:group ',(intern (concat "guix-" buf-type-str)))
(defcustom ,buf-name-var ,(format "*Guix %s %s*"
Entry-type-str Buf-type-str)
,(concat "Default name of the " buf-str " for displaying " entry-str ".")
:type 'string
:group ',group)
(defcustom ,history-var ,history-val
,(concat "Maximum number of items saved in the history of the " buf-str ".\n"
"If 0, the history is disabled.")
:type 'integer
:group ',group)
(defcustom ,revert-var ,revert-val
,(concat "If non-nil, do not ask to confirm for reverting the " buf-str ".")
:type 'boolean
:group ',group)
(defvar ,params-var ',params-val
,(concat "List of required " entry-type-str " parameters.\n\n"
"Displayed parameters and parameters from this list are received\n"
"for each " entry-type-str ".\n\n"
"May be a special value `all', in which case all supported\n"
"parameters are received (this may be very slow for a big number\n"
"of entries).\n\n"
"Do not remove `id' from this list as it is required for\n"
"identifying an entry."))
(define-derived-mode ,mode ,parent-mode ,(concat "Guix-" Buf-type-str)
,(concat "Major mode for displaying information about " entry-str ".\n\n"
"\\{" mode-map-str "}")
(setq-local revert-buffer-function ',revert-fun)
(setq-local guix-history-size ,history-var)
(and (fboundp ',mode-init-fun) (,mode-init-fun)))
(let ((map ,mode-map))
(define-key map (kbd "l") 'guix-history-back)
(define-key map (kbd "r") 'guix-history-forward)
(define-key map (kbd "g") 'revert-buffer)
(define-key map (kbd "R") ',redisplay-fun)
(define-key map (kbd "C-c C-z") 'guix-switch-to-repl))
(defun ,params-fun ()
,(concat "Return " entry-type-str " parameters that should be received.")
(unless (equal ,params-var 'all)
(cl-union ,params-var
(,(intern (concat "guix-" buf-type-str "-get-displayed-params"))
',entry-type))))
(defun ,revert-fun (_ignore-auto noconfirm)
"Update information in the current buffer.
The function is suitable for `revert-buffer-function'.
See `revert-buffer' for the meaning of NOCONFIRM."
(when (or ,revert-var
noconfirm
(y-or-n-p "Update current information? "))
(let ((entries (guix-get-entries ',entry-type guix-search-type
guix-search-vals (,params-fun))))
(,set-fun entries guix-search-type guix-search-vals t))))
(defun ,redisplay-fun ()
"Redisplay current information.
This function will not update the information, use
\"\\[revert-buffer]\" if you want the full update."
(interactive)
(,show-fun guix-entries)
(guix-result-message guix-entries ',entry-type
guix-search-type guix-search-vals))
(defun ,history-fun ()
"Make and return a history item for the current buffer."
(list (lambda (entries search-type search-vals)
(,show-fun entries)
(guix-set-vars entries search-type search-vals)
(guix-result-message entries ',entry-type
search-type search-vals))
guix-entries guix-search-type guix-search-vals))
(defun ,set-fun (entries search-type search-vals &optional history-replace)
,(concat "Set up the " buf-str " for displaying " entry-str ".\n\n"
"Display ENTRIES, set variables and make history item.\n\n"
"ENTRIES should have a form of `guix-entries'.\n\n"
"See `guix-get-entries' for the meaning of SEARCH-TYPE and\n"
"SEARCH-VALS.\n\n"
"If HISTORY-REPLACE is non-nil, replace current history item,\n"
"otherwise add the new one.")
(when entries
(let ((buf (if (eq major-mode ',mode)
(current-buffer)
(get-buffer-create ,buf-name-var))))
(with-current-buffer buf
(,show-fun entries)
(guix-set-vars entries search-type search-vals)
(funcall (if history-replace
#'guix-history-replace
#'guix-history-add)
(,history-fun)))
(pop-to-buffer buf
'((display-buffer-reuse-window
display-buffer-same-window)))))
(guix-result-message entries ',entry-type
search-type search-vals))
(defun ,show-fun (entries)
,(concat "Display " entry-type-str " ENTRIES in the current " buf-str ".")
(let ((inhibit-read-only t))
(erase-buffer)
(,mode)
(,(intern (concat "guix-" buf-type-str "-insert-entries"))
entries ',entry-type)
(goto-char (point-min))))
(defun ,get-show-fun (search-type &rest search-vals)
,(concat "Search for " entry-str " and show results in the " buf-str ".\n"
"See `guix-get-entries' for the meaning of SEARCH-TYPE and\n"
"SEARCH-VALS.")
(let ((entries (guix-get-entries ',entry-type search-type
search-vals (,params-fun))))
(,set-fun entries search-type search-vals))))))
(put 'guix-define-buffer-type 'lisp-indent-function 'defun)
;;; Messages
(defvar guix-messages
'((package
(id
(0 "Packages not found.")
(1 "")
(many "%d packages." count))
(name
(0 "The package '%s' not found." val)
(1 "A single package with name '%s'." val)
(many "%d packages with '%s' name." count val))
(regexp
(0 "No packages matching '%s'." val)
(1 "A single package matching '%s'." val)
(many "%d packages matching '%s'." count val))
(all-available
(0 "No packages are available for some reason.")
(1 "A single available package (that's strange).")
(many "%d available packages." count))
(newest-available
(0 "No packages are available for some reason.")
(1 "A single newest available package (that's strange).")
(many "%d newest available packages." count))
(installed
(0 "No installed packages.")
(1 "A single installed package.")
(many "%d installed packages." count))
(obsolete
(0 "No obsolete packages.")
(1 "A single obsolete package.")
(many "%d obsolete packages." count))
(generation
(0 "No packages installed in generation %d." val)
(1 "A single package installed in generation %d." val)
(many "%d packages installed in generation %d." count val)))
(generation
(id
(0 "Generations not found.")
(1 "")
(many "%d generations." count))
(last
(0 "No available generations.")
(1 "The last generation.")
(many "%d last generations." count))
(all
(0 "No available generations.")
(1 "A single available generation.")
(many "%d available generations." count)))))
(defun guix-result-message (entries entry-type search-type search-vals)
"Display an appropriate message after displaying ENTRIES."
(let* ((val (car search-vals))
(count (length entries))
(count-key (if (> count 1) 'many count))
(msg-spec (guix-get-key-val guix-messages
entry-type search-type count-key))
(format (car msg-spec))
(args (cdr msg-spec)))
(mapc (lambda (subst)
(setq args (cl-substitute (car subst) (cdr subst) args)))
(list (cons count 'count)
(cons val 'val)))
(apply #'message format args)))
;;; Getting info about packages and generations
(defun guix-get-entries (entry-type search-type search-vals &optional params)
"Search for entries of ENTRY-TYPE.
Call an appropriate scheme function and return a list of the
form of `guix-entries'.
ENTRY-TYPE should be one of the following symbols: `package' or
`generation'.
SEARCH-TYPE may be one of the following symbols:
- If ENTRY-TYPE is `package': `id', `name', `regexp',
`all-available', `newest-available', `installed', `obsolete',
`generation'.
- If ENTRY-TYPE is `generation': `id', `last', `all'.
PARAMS is a list of parameters for receiving. If nil, get
information with all available parameters."
(guix-eval-read (guix-make-guile-expression
'get-entries
guix-current-profile params
entry-type search-type search-vals)))
;;; Actions on packages and generations
(defcustom guix-operation-confirm t
"If nil, do not prompt to confirm an operation."
:type 'boolean
:group 'guix)
(defcustom guix-use-substitutes t
"If non-nil, use substitutes for the Guix packages."
:type 'boolean
:group 'guix)
(defvar guix-dry-run nil
"If non-nil, do not perform the real actions, just simulate.")
(defvar guix-temp-buffer-name " *Guix temp*"
"Name of a buffer used for displaying info before executing operation.")
(defun guix-process-package-actions (&rest actions)
"Process package ACTIONS.
Each action is a list of the form:
(ACTION-TYPE PACKAGE-SPEC ...)
ACTION-TYPE is one of the following symbols: `install',
`upgrade', `remove'/`delete'.
PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)."
(let (install upgrade remove)
(mapc (lambda (action)
(let ((action-type (car action))
(specs (cdr action)))
(cl-case action-type
(install (setq install (append install specs)))
(upgrade (setq upgrade (append upgrade specs)))
((remove delete) (setq remove (append remove specs))))))
actions)
(when (guix-continue-package-operation-p
:install install :upgrade upgrade :remove remove)
(guix-eval-in-repl
(guix-make-guile-expression
'process-package-actions guix-current-profile
:install install :upgrade upgrade :remove remove
:use-substitutes? (or guix-use-substitutes 'f)
:dry-run? (or guix-dry-run 'f))))))
(cl-defun guix-continue-package-operation-p (&key install upgrade remove)
"Return non-nil if a package operation should be continued.
Ask a user if needed (see `guix-operation-confirm').
INSTALL, UPGRADE, REMOVE are 'package action specifications'.
See `guix-process-package-actions' for details."
(or (null guix-operation-confirm)
(let* ((entries (guix-get-entries
'package 'id
(list (append (mapcar #'car install)
(mapcar #'car upgrade)
(mapcar #'car remove)))
'(id name version location)))
(install-strings (guix-get-package-strings install entries))
(upgrade-strings (guix-get-package-strings upgrade entries))
(remove-strings (guix-get-package-strings remove entries)))
(if (or install-strings upgrade-strings remove-strings)
(let ((buf (get-buffer-create guix-temp-buffer-name)))
(with-current-buffer buf
(setq-local cursor-type nil)
(setq buffer-read-only nil)
(erase-buffer)
(guix-insert-package-strings install-strings "install")
(guix-insert-package-strings upgrade-strings "upgrade")
(guix-insert-package-strings remove-strings "remove")
(let ((win (temp-buffer-window-show
buf
'((display-buffer-reuse-window
display-buffer-at-bottom)
(window-height . fit-window-to-buffer)))))
(prog1 (y-or-n-p "Continue operation? ")
(quit-window nil win)))))
(message "Nothing to be done. If the REPL was restarted, information is not up-to-date.")
nil))))
(defun guix-get-package-strings (specs entries)
"Return short package descriptions for performing package actions.
See `guix-process-package-actions' for the meaning of SPECS.
ENTRIES is a list of package entries to get info about packages."
(delq nil
(mapcar
(lambda (spec)
(let* ((id (car spec))
(outputs (cdr spec))
(entry (guix-get-entry-by-id id entries)))
(when entry
(let ((location (guix-get-key-val entry 'location)))
(concat (guix-get-full-name entry)
(when outputs
(concat ":"
(mapconcat #'identity outputs ",")))
(when location
(concat "\t(" location ")")))))))
specs)))
(defun guix-insert-package-strings (strings action)
"Insert information STRINGS at point for performing package ACTION."
(when strings
(insert "Package(s) to " (guix-get-string action 'bold) ":\n")
(mapc (lambda (str)
(insert " " str "\n"))
strings)
(insert "\n")))
(provide 'guix-base)
;;; guix-base.el ends here

64
emacs/guix-helper.scm.in Normal file
View File

@ -0,0 +1,64 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This is an auxiliary file for the Emacs UI. It is used to add Guix
;; directories to path variables and to load the main code.
;;; Code:
(use-modules (ice-9 regex)
(srfi srfi-26))
(define %guix-dir)
;; The code is taken from ‘guix’ executable script
(define (set-paths!)
(define-syntax-rule (push! elt v) (set! v (cons elt v)))
(define config-lookup
(let ((config '(("prefix" . "@prefix@")
("guilemoduledir" . "@guilemoduledir@")))
(var-ref-regexp (make-regexp "\\$\\{([a-z]+)\\}")))
(define (expand-var-ref match)
(lookup (match:substring match 1)))
(define (expand str)
(regexp-substitute/global #f var-ref-regexp str
'pre expand-var-ref 'post))
(define (lookup name)
(expand (assoc-ref config name)))
lookup))
(let ((module-dir (config-lookup "guilemoduledir"))
(updates-dir (and=> (or (getenv "XDG_CONFIG_HOME")
(and=> (getenv "HOME")
(cut string-append <> "/.config")))
(cut string-append <> "/guix/latest"))))
(push! module-dir %load-compiled-path)
(if (and updates-dir (file-exists? updates-dir))
(begin
(set! %guix-dir updates-dir)
(push! updates-dir %load-path)
(push! updates-dir %load-compiled-path))
(set! %guix-dir module-dir))))
(set-paths!)
(load-from-path "guix-main")

92
emacs/guix-history.el Normal file
View File

@ -0,0 +1,92 @@
;;; guix-history.el --- History of buffer information
;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;; This file is part of GNU Guix.
;; GNU Guix is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Guix is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides support for history of buffers similar to the
;; history of a `help-mode' buffer.
;;; Code:
(require 'cl-macs)
(defvar-local guix-history-stack-item nil
"Current item of the history.
A list of the form (FUNCTION [ARGS ...]).
The item is used by calling (apply FUNCTION ARGS).")
(put 'guix-history-stack-item 'permanent-local t)
(defvar-local guix-history-back-stack nil
"Stack (list) of visited items.
Each element of the list has a form of `guix-history-stack-item'.")
(put 'guix-history-back-stack 'permanent-local t)
(defvar-local guix-history-forward-stack nil
"Stack (list) of items visited with `guix-history-back'.
Each element of the list has a form of `guix-history-stack-item'.")
(put 'guix-history-forward-stack 'permanent-local t)
(defvar guix-history-size 0
"Maximum number of items saved in history.
If 0, the history is disabled.")
(defun guix-history-add (item)
"Add ITEM to history."
(and guix-history-stack-item
(push guix-history-stack-item guix-history-back-stack))
(setq guix-history-forward-stack nil
guix-history-stack-item item)
(when (>= (length guix-history-back-stack)
guix-history-size)
(setq guix-history-back-stack
(cl-loop for elt in guix-history-back-stack
for i from 1 to guix-history-size
collect elt))))
(defun guix-history-replace (item)
"Replace current item in history with ITEM."
(setq guix-history-stack-item item))
(defun guix-history-goto (item)
"Go to the ITEM of history.
ITEM should have the form of `guix-history-stack-item'."
(or (listp item)
(error "Wrong value of history element"))
(setq guix-history-stack-item item)
(apply (car item) (cdr item)))
(defun guix-history-back ()
"Go back to the previous element of history in the current buffer."
(interactive)
(or guix-history-back-stack
(user-error "No previous element in history"))
(push guix-history-stack-item guix-history-forward-stack)
(guix-history-goto (pop guix-history-back-stack)))
(defun guix-history-forward ()
"Go forward to the next element of history in the current buffer."
(interactive)
(or guix-history-forward-stack
(user-error "No next element in history"))
(push guix-history-stack-item guix-history-back-stack)
(guix-history-goto (pop guix-history-forward-stack)))
(provide 'guix-history)
;;; guix-history.el ends here

556
emacs/guix-info.el Normal file
View File

@ -0,0 +1,556 @@
;;; guix-info.el --- Info buffers for displaying entries
;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;; This file is part of GNU Guix.
;; GNU Guix is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Guix is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides a help-like buffer for displaying information
;; about Guix packages and generations.
;;; Code:
(require 'guix-history)
(require 'guix-base)
(require 'guix-utils)
(defgroup guix-info nil
"General settings for info buffers."
:prefix "guix-info-"
:group 'guix)
(defface guix-info-param-title
'((t :inherit font-lock-type-face))
"Face used for titles of parameters."
:group 'guix-info)
(defface guix-info-file-path
'((t :inherit link))
"Face used for file paths."
:group 'guix-info)
(defface guix-info-url
'((t :inherit link))
"Face used for URLs."
:group 'guix-info)
(defface guix-info-time
'((t :inherit font-lock-constant-face))
"Face used for timestamps."
:group 'guix-info)
(defface guix-info-action-button
'((((type x w32 ns) (class color))
:box (:line-width 2 :style released-button)
:background "lightgrey" :foreground "black")
(t :inherit button))
"Face used for action buttons."
:group 'guix-info)
(defface guix-info-action-button-mouse
'((((type x w32 ns) (class color))
:box (:line-width 2 :style released-button)
:background "grey90" :foreground "black")
(t :inherit highlight))
"Mouse face used for action buttons."
:group 'guix-info)
(defcustom guix-info-ignore-empty-vals nil
"If non-nil, do not display parameters with nil values."
:type 'boolean
:group 'guix-info)
(defvar guix-info-param-title-format "%-18s: "
"String used to format a title of a parameter.
It should be a '%s'-sequence. After inserting a title formatted
with this string, a value of the parameter is inserted.
This string is used by `guix-info-insert-title-default'.")
(defvar guix-info-multiline-prefix (make-string 20 ?\s)
"String used to format multi-line parameter values.
If a value occupies more than one line, this string is inserted
in the beginning of each line after the first one.
This string is used by `guix-info-insert-val-default'.")
(defvar guix-info-indent 2
"Number of spaces used to indent various parts of inserted text.")
(defvar guix-info-fill-column 60
"Column used for filling (word wrapping) parameters with long lines.
If a value is not multi-line and it occupies more than this
number of characters, it will be split into several lines.")
(defvar guix-info-delimiter "\n\f\n"
"String used to separate entries.")
(defvar guix-info-insert-methods
'((package
(name guix-package-info-name)
(version guix-package-info-version)
(license guix-package-info-license)
(synopsis guix-package-info-synopsis)
(description guix-package-info-insert-description
guix-info-insert-title-simple)
(outputs guix-package-info-insert-outputs
guix-info-insert-title-simple)
(home-url guix-info-insert-url)
(inputs guix-package-info-insert-inputs)
(native-inputs guix-package-info-insert-native-inputs)
(propagated-inputs guix-package-info-insert-propagated-inputs)
(location guix-package-info-insert-location))
(installed
(path guix-package-info-insert-output-path
guix-info-insert-title-simple)
(dependencies guix-package-info-insert-output-dependencies
guix-info-insert-title-simple))
(generation
(number guix-generation-info-insert-number)
(path guix-info-insert-file-path)
(time guix-info-insert-time)))
"Methods for inserting parameter values.
Each element of the list should have a form:
(ENTRY-TYPE . ((PARAM INSERT-VALUE [INSERT-TITLE]) ...))
INSERT-VALUE may be either nil, a face name or a function. If it
is nil or a face, `guix-info-insert-val-default' function is
called with parameter value and INSERT-VALUE as arguments. If it
is a function, this function is called with parameter value and
entry info (alist of parameters and their values) as arguments.
INSERT-TITLE may be either nil, a face name or a function. If it
is nil or a face, `guix-info-insert-title-default' function is
called with parameter title and INSERT-TITLE as arguments. If it
is a function, this function is called with parameter title as
argument.")
(defvar guix-info-displayed-params
'((package name version synopsis outputs location home-url
license inputs native-inputs propagated-inputs description)
(installed path dependencies)
(generation number prev-number time path))
"List of displayed entry parameters.
Each element of the list should have a form:
(ENTRY-TYPE . (PARAM ...))
The order of displayed parameters is the same as in this list.")
(defun guix-info-get-insert-methods (entry-type param)
"Return list of insert methods for parameter PARAM of ENTRY-TYPE.
See `guix-info-insert-methods' for details."
(guix-get-key-val guix-info-insert-methods
entry-type param))
(defun guix-info-get-displayed-params (entry-type)
"Return parameters of ENTRY-TYPE that should be displayed."
(guix-get-key-val guix-info-displayed-params
entry-type))
(defun guix-info-get-indent (&optional level)
"Return `guix-info-indent' \"multiplied\" by LEVEL spaces.
LEVEL is 1 by default."
(make-string (* guix-info-indent (or level 1)) ?\s))
(defun guix-info-insert-indent (&optional level)
"Insert `guix-info-indent' spaces LEVEL times (1 by default)."
(insert (guix-info-get-indent level)))
(defun guix-info-insert-entries (entries entry-type)
"Display ENTRIES of ENTRY-TYPE in the current info buffer.
ENTRIES should have a form of `guix-entries'."
(guix-mapinsert (lambda (entry)
(guix-info-insert-entry entry entry-type))
entries
guix-info-delimiter))
(defun guix-info-insert-entry (entry entry-type &optional indent-level)
"Insert ENTRY of ENTRY-TYPE into the current info buffer.
If INDENT-LEVEL is non-nil, indent displayed information by this
number of `guix-info-indent' spaces."
(let ((region-beg (point)))
(mapc (lambda (param)
(guix-info-insert-param param entry entry-type))
(guix-info-get-displayed-params entry-type))
(when indent-level
(indent-rigidly region-beg (point)
(* indent-level guix-info-indent)))))
(defun guix-info-insert-param (param entry entry-type)
"Insert title and value of a PARAM at point.
ENTRY is alist with parameters and their values.
ENTRY-TYPE is a type of ENTRY."
(let ((val (guix-get-key-val entry param)))
(unless (and guix-info-ignore-empty-vals (null val))
(let* ((title (guix-get-param-title entry-type param))
(insert-methods (guix-info-get-insert-methods entry-type param))
(val-method (car insert-methods))
(title-method (cadr insert-methods)))
(guix-info-method-funcall title title-method
#'guix-info-insert-title-default)
(guix-info-method-funcall val val-method
#'guix-info-insert-val-default
entry)
(insert "\n")))))
(defun guix-info-method-funcall (val method default-fun &rest args)
"Call METHOD or DEFAULT-FUN.
If METHOD is a function and VAL is non-nil, call this
function by applying it to VAL and ARGS.
If METHOD is a face, propertize inserted VAL with this face."
(cond ((or (null method)
(facep method))
(funcall default-fun val method))
((functionp method)
(apply method val args))
(t (error "Unknown method '%S'" method))))
(defun guix-info-insert-title-default (title &optional face format)
"Insert TITLE formatted with `guix-info-param-title-format' at point."
(guix-format-insert title
(or face 'guix-info-param-title)
(or format guix-info-param-title-format)))
(defun guix-info-insert-title-simple (title &optional face)
"Insert TITLE at point."
(guix-info-insert-title-default title face "%s:"))
(defun guix-info-insert-val-default (val &optional face)
"Format and insert parameter value VAL at point.
This function is intended to be called after
`guix-info-insert-title-default'.
If VAL is a one-line string longer than `guix-info-fill-column',
split it into several short lines. See also
`guix-info-multiline-prefix'.
If FACE is non-nil, propertize inserted line(s) with this FACE."
(guix-split-insert val face
guix-info-fill-column
(concat "\n" guix-info-multiline-prefix)))
(defun guix-info-insert-val-simple (val &optional face-or-fun)
"Format and insert parameter value VAL at point.
This function is intended to be called after
`guix-info-insert-title-simple'.
If VAL is a one-line string longer than `guix-info-fill-column',
split it into several short lines and indent each line with
`guix-info-indent' spaces.
If FACE-OR-FUN is a face, propertize inserted line(s) with this FACE.
If FACE-OR-FUN is a function, call it with VAL as argument. If
VAL is a list, call the function on each element of this list."
(if (null val)
(progn (guix-info-insert-indent)
(guix-format-insert nil))
(let ((prefix (concat "\n" (guix-info-get-indent))))
(insert prefix)
(if (functionp face-or-fun)
(guix-mapinsert face-or-fun
(if (listp val) val (list val))
prefix)
(guix-split-insert val face-or-fun
guix-info-fill-column prefix)))))
(defun guix-info-insert-action-button (label action &optional message
&rest properties)
"Make action button with LABEL and insert it at point.
For the meaning of ACTION, MESSAGE and PROPERTIES, see
`guix-insert-button'."
(apply #'guix-insert-button
label 'guix-info-action-button action message
'mouse-face 'guix-info-action-button-mouse
properties))
(defun guix-info-insert-file-path (path &optional _)
"Make button from file PATH and insert it at point."
(guix-insert-button
path 'guix-info-file-path
(lambda (btn) (find-file (button-label btn)))
"Find file"))
(defun guix-info-insert-url (url &optional _)
"Make button from URL and insert it at point."
(guix-insert-button
url 'guix-info-url
(lambda (btn) (browse-url (button-label btn)))
"Browse URL"))
(defun guix-info-insert-time (seconds &optional _)
"Insert formatted time string using SECONDS at point."
(guix-info-insert-val-default (guix-get-time-string seconds)
'guix-info-time))
(defvar guix-info-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent
map (make-composed-keymap button-buffer-map
special-mode-map))
map)
"Parent keymap for info buffers.")
(define-derived-mode guix-info-mode special-mode "Guix-Info"
"Parent mode for displaying information in info buffers.")
;;; Displaying packages
(guix-define-buffer-type info package
:required (id installed non-unique))
(defface guix-package-info-name
'((t :inherit font-lock-keyword-face))
"Face used for a name of a package."
:group 'guix-package-info)
(defface guix-package-info-version
'((t :inherit font-lock-builtin-face))
"Face used for a version of a package."
:group 'guix-package-info)
(defface guix-package-info-synopsis
'((t :inherit font-lock-doc-face))
"Face used for a synopsis of a package."
:group 'guix-package-info)
(defface guix-package-info-description
'((t))
"Face used for a description of a package."
:group 'guix-package-info)
(defface guix-package-info-license
'((t :inherit font-lock-string-face))
"Face used for a license of a package."
:group 'guix-package-info)
(defface guix-package-info-location
'((t :inherit link))
"Face used for a location of a package."
:group 'guix-package-info)
(defface guix-package-info-installed-outputs
'((default :weight bold)
(((class color) (min-colors 88) (background light))
:foreground "ForestGreen")
(((class color) (min-colors 88) (background dark))
:foreground "PaleGreen")
(((class color) (min-colors 8))
:foreground "green")
(t :underline t))
"Face used for installed outputs of a package."
:group 'guix-package-info)
(defface guix-package-info-uninstalled-outputs
'((t :weight bold))
"Face used for uninstalled outputs of a package."
:group 'guix-package-info)
(defface guix-package-info-obsolete
'((t :inherit error))
"Face used if a package is obsolete."
:group 'guix-package-info)
(defun guix-package-info-insert-description (desc &optional _)
"Insert description DESC at point."
(guix-info-insert-val-simple desc 'guix-package-info-description))
(defun guix-package-info-insert-location (location &optional _)
"Make button from file LOCATION and insert it at point."
(guix-insert-button
location 'guix-package-info-location
(lambda (btn) (guix-find-location (button-label btn)))
"Find location of this package"))
(defmacro guix-package-info-define-insert-inputs (&optional type)
"Define a face and a function for inserting package inputs.
TYPE is a type of inputs.
Function name is `guix-package-info-insert-TYPE-inputs'.
Face name is `guix-package-info-TYPE-inputs'."
(let* ((type-str (symbol-name type))
(type-name (and type (concat type-str "-")))
(type-desc (and type (concat type-str " ")))
(face (intern (concat "guix-package-info-" type-name "inputs")))
(fun (intern (concat "guix-package-info-insert-" type-name "inputs"))))
`(progn
(defface ,face
'((t :inherit button))
,(concat "Face used for " type-desc "inputs of a package.")
:group 'guix-package-info)
(defun ,fun (inputs &optional _)
,(concat "Make buttons from " type-desc "INPUTS and insert them at point.")
(guix-package-info-insert-full-names inputs ',face)))))
(guix-package-info-define-insert-inputs)
(guix-package-info-define-insert-inputs native)
(guix-package-info-define-insert-inputs propagated)
(defun guix-package-info-insert-full-names (names face)
"Make buttons from package NAMES and insert them at point.
NAMES is a list of strings.
Propertize buttons with FACE."
(if names
(guix-info-insert-val-default
(with-temp-buffer
(guix-mapinsert (lambda (name)
(guix-package-info-insert-full-name
name face))
names
guix-list-separator)
(buffer-substring (point-min) (point-max))))
(guix-format-insert nil)))
(defun guix-package-info-insert-full-name (name face)
"Make button and insert package NAME at point.
Propertize package button with FACE."
(guix-insert-button
name face
(lambda (btn)
(guix-package-info-get-show 'name (button-label btn)))
"Describe this package"))
;;; Inserting outputs and installed parameters
(defvar guix-package-info-output-format "%-10s"
"String used to format output names of the packages.
It should be a '%s'-sequence. After inserting an output name
formatted with this string, an action button is inserted.")
(defvar guix-package-info-obsolete-string "(This package is obsolete)"
"String used if a package is obsolete.")
(defun guix-package-info-insert-outputs (outputs entry)
"Insert OUTPUTS from package ENTRY at point."
(and (guix-get-key-val entry 'obsolete)
(guix-package-info-insert-obsolete-text))
(and (guix-get-key-val entry 'non-unique)
(guix-get-key-val entry 'installed)
(guix-package-info-insert-non-unique-text
(guix-get-full-name entry)))
(insert "\n")
(mapc (lambda (output)
(guix-package-info-insert-output output entry))
outputs))
(defun guix-package-info-insert-obsolete-text ()
"Insert a message about obsolete package at point."
(guix-info-insert-indent)
(guix-format-insert guix-package-info-obsolete-string
'guix-package-info-obsolete))
(defun guix-package-info-insert-non-unique-text (full-name)
"Insert a message about non-unique package with FULL-NAME at point."
(insert "\n")
(guix-info-insert-indent)
(insert "Installed outputs are displayed for a non-unique ")
(guix-package-info-insert-full-name full-name
'guix-package-info-inputs)
(insert " package."))
(defun guix-package-info-insert-output (output entry)
"Insert OUTPUT at point.
Make some fancy text with buttons and additional stuff if the
current OUTPUT is installed (if there is such output in
`installed' parameter of a package ENTRY)."
(let* ((installed (guix-get-key-val entry 'installed))
(obsolete (guix-get-key-val entry 'obsolete))
(installed-entry (cl-find-if
(lambda (entry)
(string= (guix-get-key-val entry 'output)
output))
installed))
(action-type (if installed-entry 'delete 'install)))
(guix-info-insert-indent)
(guix-format-insert output
(if installed-entry
'guix-package-info-installed-outputs
'guix-package-info-uninstalled-outputs)
guix-package-info-output-format)
(guix-package-info-insert-action-button action-type entry output)
(when obsolete
(guix-info-insert-indent)
(guix-package-info-insert-action-button 'upgrade entry output))
(insert "\n")
(when installed-entry
(guix-info-insert-entry installed-entry 'installed 2))))
(defun guix-package-info-insert-action-button (type entry output)
"Insert button to process an action on a package OUTPUT at point.
TYPE is one of the following symbols: `install', `delete', `upgrade'.
ENTRY is an alist with package info."
(let ((type-str (capitalize (symbol-name type)))
(full-name (guix-get-full-name entry output)))
(guix-info-insert-action-button
type-str
(lambda (btn)
(guix-process-package-actions
(list (button-get btn 'action-type)
(list (button-get btn 'id)
(button-get btn 'output)))))
(concat type-str " '" full-name "'")
'action-type type
'id (guix-get-key-val entry 'id)
'output output)))
(defun guix-package-info-insert-output-path (path &optional _)
"Insert PATH of the installed output."
(guix-info-insert-val-simple path #'guix-info-insert-file-path))
(defun guix-package-info-insert-output-dependencies (deps &optional _)
"Insert dependencies DEPS of the installed output."
(guix-info-insert-val-simple deps #'guix-info-insert-file-path))
;;; Displaying generations
(guix-define-buffer-type info generation)
(defface guix-generation-info-number
'((t :inherit font-lock-keyword-face))
"Face used for a number of a generation."
:group 'guix-generation-info)
(declare-function guix-package-list-get-show "guix-list" t t)
(defun guix-generation-info-insert-number (number &optional _)
"Insert generation NUMBER and action buttons."
(guix-info-insert-val-default number 'guix-generation-info-number)
(guix-info-insert-indent)
(guix-info-insert-action-button
"Packages"
(lambda (btn)
(guix-package-list-get-show 'generation
(button-get btn 'number)))
"Show installed packages for this generation"
'number number)
(guix-info-insert-indent)
(guix-info-insert-action-button
"Delete"
(lambda (btn) (error "Sorry, not implemented yet"))
"Delete this generation"))
(provide 'guix-info)
;;; guix-info.el ends here

14
emacs/guix-init.el.in Normal file
View File

@ -0,0 +1,14 @@
(require 'guix-autoloads)
(defvar guix-load-path
(replace-regexp-in-string "${prefix}" "@prefix@" "@emacsuidir@")
"Directory with scheme files for \"guix.el\" package.")
(defvar guix-default-profile
(concat (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix")
"/profiles/per-user/"
(getenv "USER")
"/guix-profile")
"Default Guix profile.")
(provide 'guix-init)

594
emacs/guix-list.el Normal file
View File

@ -0,0 +1,594 @@
;;; guix-list.el --- List buffers for displaying entries -*- lexical-binding: t -*-
;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;; This file is part of GNU Guix.
;; GNU Guix is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Guix is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides a list-like buffer for displaying information
;; about Guix packages and generations.
;;; Code:
(require 'cl-lib)
(require 'tabulated-list)
(require 'guix-info)
(require 'guix-history)
(require 'guix-base)
(require 'guix-utils)
(defgroup guix-list nil
"General settings for list buffers."
:prefix "guix-list-"
:group 'guix)
(defface guix-list-file-path
'((t :inherit guix-info-file-path))
"Face used for file paths."
:group 'guix-list)
(defcustom guix-list-describe-warning-count 10
"The maximum number of entries for describing without a warning.
If a user wants to describe more than this number of marked
entries, he will be prompted for confirmation."
:type 'integer
:group 'guix-list)
(defvar guix-list-column-format
`((package
(name 20 t)
(version 10 nil)
(outputs 13 t)
(installed 13 t)
(synopsis 30 nil))
(generation
(number 5
,(lambda (a b) (guix-list-sort-numerically 0 a b))
:right-align t)
(time 20 t)
(path 30 t)))
"Columns displayed in list buffers.
Each element of the list has a form:
(ENTRY-TYPE . ((PARAM WIDTH SORT . PROPS) ...))
PARAM is the name of an entry parameter of ENTRY-TYPE. For the
meaning of WIDTH, SORT and PROPS, see `tabulated-list-format'.")
(defvar guix-list-column-titles
'((generation
(number . "N.")))
"Column titles for list buffers.
Has the same structure as `guix-param-titles', but titles from
this list have a priority.")
(defvar guix-list-column-value-methods
'((package
(name . guix-package-list-get-name)
(synopsis . guix-list-get-one-line)
(description . guix-list-get-one-line)
(installed . guix-package-list-get-installed-outputs))
(generation
(time . guix-list-get-time)
(path . guix-list-get-file-path)))
"Methods for inserting parameter values in columns.
Each element of the list has a form:
(ENTRY-TYPE . ((PARAM . FUN) ...))
PARAM is the name of an entry parameter of ENTRY-TYPE.
FUN is a function returning a value that will be inserted. The
function is called with 2 arguments: the first one is the value
of the parameter; the second argument is an entry info (alist of
parameters and their values).")
(defun guix-list-get-param-title (entry-type param)
"Return title of an ENTRY-TYPE entry parameter PARAM."
(or (guix-get-key-val guix-list-column-titles
entry-type param)
(guix-get-param-title entry-type param)))
(defun guix-list-get-column-format (entry-type)
"Return column format for ENTRY-TYPE."
(guix-get-key-val guix-list-column-format entry-type))
(defun guix-list-get-displayed-params (entry-type)
"Return list of parameters of ENTRY-TYPE that should be displayed."
(mapcar #'car
(guix-list-get-column-format entry-type)))
(defun guix-list-get-sort-key (entry-type param &optional invert)
"Return suitable sort key for `tabulated-list-sort-key'.
Define column title by ENTRY-TYPE and PARAM. If INVERT is
non-nil, invert the sort."
(when (memq param (guix-list-get-displayed-params entry-type))
(cons (guix-list-get-param-title entry-type param) invert)))
(defun guix-list-sort-numerically (column a b)
"Compare COLUMN of tabulated entries A and B numerically.
It is a sort predicate for `tabulated-list-format'.
Return non-nil, if B is bigger than A."
(cl-flet ((num (entry)
(string-to-number (aref (cadr entry) column))))
(> (num b) (num a))))
(defun guix-list-make-tabulated-vector (entry-type fun)
"Call FUN on each column specification for ENTRY-TYPE.
FUN is called with 2 argument: parameter name and column
specification (see `guix-list-column-format').
Return a vector made of values of FUN calls."
(apply #'vector
(mapcar (lambda (col-spec)
(funcall fun (car col-spec) (cdr col-spec)))
(guix-list-get-column-format entry-type))))
(defun guix-list-get-list-format (entry-type)
"Return ENTRY-TYPE list specification for `tabulated-list-format'."
(guix-list-make-tabulated-vector
entry-type
(lambda (param spec)
(cons (guix-list-get-param-title entry-type param)
spec))))
(defun guix-list-insert-entries (entries entry-type)
"Display ENTRIES of ENTRY-TYPE in the current list buffer.
ENTRIES should have a form of `guix-entries'."
(setq tabulated-list-entries
(guix-list-get-tabulated-entries entries entry-type))
(tabulated-list-print))
(defun guix-list-get-tabulated-entries (entries entry-type)
"Return list of values of ENTRY-TYPE for `tabulated-list-entries'.
Values are taken from ENTRIES which should have the form of
`guix-entries'."
(mapcar (lambda (entry)
(list (guix-get-key-val entry 'id)
(guix-list-get-tabulated-entry entry entry-type)))
entries))
(defun guix-list-get-tabulated-entry (entry entry-type)
"Return array of values for `tabulated-list-entries'.
Parameters are taken from ENTRY of ENTRY-TYPE."
(guix-list-make-tabulated-vector
entry-type
(lambda (param _)
(let ((val (guix-get-key-val entry param))
(fun (guix-get-key-val guix-list-column-value-methods
entry-type param)))
(if (and val fun)
(funcall fun val entry)
(guix-get-string val))))))
(defun guix-list-get-one-line (str &optional _)
"Return one-line string from a multi-line STR."
(guix-get-one-line str))
(defun guix-list-get-time (seconds &optional _)
"Return formatted time string from SECONDS."
(guix-get-time-string seconds))
(defun guix-list-get-file-path (path &optional _)
"Return PATH button specification for `tabulated-list-entries'."
(list path
'face 'guix-list-file-path
'action (lambda (btn) (find-file (button-label btn)))
'follow-link t
'help-echo "Find file"))
(defun guix-list-current-id ()
"Return ID of the current entry."
(or (tabulated-list-get-id)
(user-error "No entry here")))
(defun guix-list-current-entry ()
"Return alist of the current entry info."
(guix-get-entry-by-id (guix-list-current-id) guix-entries))
(defun guix-list-for-each-line (fun &rest args)
"Call FUN with ARGS for each entry line."
(or (derived-mode-p 'guix-list-mode)
(error "The current buffer is not in Guix List mode"))
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(apply fun args)
(forward-line))))
(defun guix-list-fold-lines (fun init)
"Fold over entry lines in the current list buffer.
Call FUN with RESULT as argument for each line, using INIT as
the initial value of RESULT. Return the final result."
(let ((res init))
(guix-list-for-each-line
(lambda () (setq res (funcall fun res))))
res))
;;; Marking and sorting
(defvar-local guix-list-marked nil
"List of the marked entries.
Each element of the list has a form:
(ID MARK-NAME . ARGS)
ID is an entry ID.
MARK-NAME is a symbol from `guix-list-mark-alist'.
ARGS is a list of additional values.")
(defvar guix-list-mark-alist
'((empty . ?\s)
(general . ?*))
"Alist of available mark names and mark characters.")
(defsubst guix-list-get-mark (name)
"Return mark character by its NAME."
(or (guix-get-key-val guix-list-mark-alist name)
(error "Mark '%S' not found" name)))
(defsubst guix-list-get-mark-string (name)
"Return mark string by its NAME."
(string (guix-list-get-mark name)))
(defun guix-list-current-mark ()
"Return mark character of the current line."
(char-after (line-beginning-position)))
(defun guix-list-get-marked (&rest mark-names)
"Return list of specs of entries marked with any mark from MARK-NAMES.
Entry specs are elements from `guix-list-marked' list.
If MARK-NAMES are not specified, use all marks from
`guix-list-mark-alist' except the `empty' one."
(or mark-names
(setq mark-names
(delq 'empty
(mapcar #'car guix-list-mark-alist))))
(cl-remove-if-not (lambda (assoc)
(memq (cadr assoc) mark-names))
guix-list-marked))
(defun guix-list-get-marked-args (mark-name)
"Return list of (ID . ARGS) elements from lines marked with MARK-NAME.
See `guix-list-marked' for the meaning of ARGS."
(mapcar (lambda (spec)
(let ((id (car spec))
(args (cddr spec)))
(cons id args)))
(guix-list-get-marked mark-name)))
(defun guix-list-get-marked-id-list (&rest mark-names)
"Return list of IDs of entries marked with any mark from MARK-NAMES.
See `guix-list-get-marked' for details."
(mapcar #'car (apply #'guix-list-get-marked mark-names)))
(defun guix-list-mark (mark-name &optional advance &rest args)
"Put a mark on the current line.
Also add the current entry to `guix-list-marked' using its ID and ARGS.
MARK-NAME is a symbol from `guix-list-mark-alist'.
If ADVANCE is non-nil, move forward by one line after marking.
Interactively, put a general mark and move to the next line."
(interactive '(general t))
(let ((id (guix-list-current-id)))
(if (eq mark-name 'empty)
(setq guix-list-marked (assq-delete-all id guix-list-marked))
(let ((assoc (assq id guix-list-marked))
(val (cons mark-name args)))
(if assoc
(setcdr assoc val)
(push (cons id val) guix-list-marked)))))
(tabulated-list-put-tag (guix-list-get-mark-string mark-name)
advance))
(defun guix-list-mark-all (mark-name)
"Mark all lines with MARK-NAME mark.
MARK-NAME is a symbol from `guix-list-mark-alist'.
Interactively, put a general mark on all lines."
(interactive '(general))
(guix-list-for-each-line #'guix-list-mark mark-name))
(defun guix-list-unmark ()
"Unmark the current line and move to the next line."
(interactive)
(guix-list-mark 'empty t))
(defun guix-list-unmark-backward ()
"Move up one line and unmark it."
(interactive)
(forward-line -1)
(guix-list-mark 'empty))
(defun guix-list-unmark-all ()
"Unmark all lines."
(interactive)
(guix-list-mark-all 'empty))
(defun guix-list-restore-marks ()
"Put marks according to `guix-list-mark-alist'."
(guix-list-for-each-line
(lambda ()
(let ((mark-name (car (guix-get-key-val guix-list-marked
(guix-list-current-id)))))
(tabulated-list-put-tag
(guix-list-get-mark-string (or mark-name 'empty)))))))
(defun guix-list-sort (&optional n)
"Sort guix list entries by the column at point.
With a numeric prefix argument N, sort the Nth column.
Same as `tabulated-list-sort', but also restore marks after sorting."
(interactive "P")
(tabulated-list-sort n)
(guix-list-restore-marks))
(defvar guix-list-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map tabulated-list-mode-map)
(define-key map (kbd "m") 'guix-list-mark)
(define-key map (kbd "*") 'guix-list-mark)
(define-key map (kbd "M") 'guix-list-mark-all)
(define-key map (kbd "u") 'guix-list-unmark)
(define-key map (kbd "U") 'guix-list-unmark-all)
(define-key map (kbd "DEL") 'guix-list-unmark-backward)
(define-key map [remap tabulated-list-sort] 'guix-list-sort)
map)
"Parent keymap for list buffers.")
(define-derived-mode guix-list-mode tabulated-list-mode "Guix-List"
"Parent mode for displaying information in list buffers."
(setq tabulated-list-padding 2))
(defmacro guix-list-define-entry-type (entry-type &rest args)
"Define common stuff for displaying ENTRY-TYPE entries in list buffers.
Remaining argument (ARGS) should have a form [KEYWORD VALUE] ... The
following keywords are available:
- `:sort-key' - default sort key for the tabulated list buffer.
- `:invert-sort' - if non-nil, invert initial sort.
- `:marks' - default value for the defined
`guix-ENTRY-TYPE-mark-alist' variable.
This macro defines the following functions:
- `guix-ENTRY-TYPE-describe' - display marked entries in info buffer.
- `guix-ENTRY-TYPE-mark-MARK-NAME' functions for each mark
specified in `:marks' argument."
(let* ((entry-type-str (symbol-name entry-type))
(entry-str (concat entry-type-str " entries"))
(prefix (concat "guix-" entry-type-str "-list"))
(mode-str (concat prefix "-mode"))
(init-fun (intern (concat prefix "-mode-initialize")))
(describe-fun (intern (concat prefix "-describe")))
(marks-var (intern (concat prefix "-mark-alist")))
(marks-val nil)
(sort-key nil)
(invert-sort nil))
;; Process the keyword args.
(while (keywordp (car args))
(pcase (pop args)
(`:sort-key (setq sort-key (pop args)))
(`:invert-sort (setq invert-sort (pop args)))
(`:marks (setq marks-val (pop args)))
(_ (pop args))))
`(progn
(defvar ,marks-var ',marks-val
,(concat "Alist of additional marks for `" mode-str "'.\n"
"Marks from this list are added to `guix-list-mark-alist'."))
,@(mapcar (lambda (mark-spec)
(let* ((mark-name (car mark-spec))
(mark-name-str (symbol-name mark-name)))
`(defun ,(intern (concat prefix "-mark-" mark-name-str "-simple")) ()
,(concat "Put '" mark-name-str "' mark and move to the next line.\n"
"Also add the current entry to `guix-list-marked'.")
(interactive)
(guix-list-mark ',mark-name t))))
marks-val)
(defun ,describe-fun (&optional arg)
,(concat "Describe " entry-str " marked with a general mark.\n"
"If no entry is marked, describe the current " entry-type-str ".\n"
"With prefix (if ARG is non-nil), describe the " entry-str "\n"
"marked with any mark.")
(interactive "P")
(let* ((ids (or (apply #'guix-list-get-marked-id-list
(unless arg '(general)))
(list (guix-list-current-id))))
(count (length ids)))
(when (or (<= count guix-list-describe-warning-count)
(y-or-n-p (format "Do you really want to describe %d entries? "
count)))
(,(intern (concat "guix-" entry-type-str "-info-get-show"))
'id ids))))
(defun ,init-fun ()
,(concat "Initial settings for `" mode-str "'.")
,(when sort-key
`(setq tabulated-list-sort-key
(guix-list-get-sort-key
',entry-type ',sort-key ,invert-sort)))
(setq tabulated-list-format
(guix-list-get-list-format ',entry-type))
(setq-local guix-list-mark-alist
(append guix-list-mark-alist ,marks-var))
(tabulated-list-init-header)))))
(put 'guix-list-define-entry-type 'lisp-indent-function 'defun)
;;; Displaying packages
(guix-define-buffer-type list package)
(guix-list-define-entry-type package
:sort-key name
:marks ((install . ?I)
(upgrade . ?U)
(delete . ?D)))
(defface guix-package-list-installed
'((t :inherit guix-package-info-installed-outputs))
"Face used if there are installed outputs for the current package."
:group 'guix-package-list)
(defface guix-package-list-obsolete
'((t :inherit guix-package-info-obsolete))
"Face used if a package is obsolete."
:group 'guix-package-list)
(defcustom guix-package-list-generation-marking-enabled nil
"If non-nil, allow putting marks in a list with 'generation packages'.
By default this is disabled, because it may be confusing. For
example a package is installed in some generation, so a user can
mark it for deletion in the list of packages from this
generation, but the package may not be installed in the latest
generation, so actually it cannot be deleted.
If you managed to understand the explanation above or if you
really know what you do or if you just don't care, you can set
this variable to t. It should not do much harm anyway (most
likely)."
:type 'boolean
:group 'guix-package-list)
(let ((map guix-package-list-mode-map))
(define-key map (kbd "RET") 'guix-package-list-describe)
(define-key map (kbd "x") 'guix-package-list-execute)
(define-key map (kbd "i") 'guix-package-list-mark-install)
(define-key map (kbd "^") 'guix-package-list-mark-upgrade)
(define-key map (kbd "d") 'guix-package-list-mark-delete))
(defun guix-package-list-get-name (name entry)
"Return NAME of the package ENTRY.
Colorize it with `guix-package-list-installed' or
`guix-package-list-obsolete' if needed."
(guix-get-string name
(cond ((guix-get-key-val entry 'obsolete)
'guix-package-list-obsolete)
((guix-get-key-val entry 'installed)
'guix-package-list-installed))))
(defun guix-package-list-get-installed-outputs (installed &optional _)
"Return string with outputs from INSTALLED entries."
(guix-get-string
(mapcar (lambda (entry)
(guix-get-key-val entry 'output))
installed)))
(defun guix-package-list-marking-check ()
"Signal an error if marking is disabled for the current buffer."
(when (and (not guix-package-list-generation-marking-enabled)
(derived-mode-p 'guix-package-list-mode)
(eq guix-search-type 'generation))
(error "Action marks are disabled for lists of 'generation packages'")))
(defun guix-package-list-mark-install (&optional arg)
"Mark the current package for installation and move to the next line.
With ARG, prompt for the outputs to install (several outputs may
be separated with \",\")."
(interactive "P")
(guix-package-list-marking-check)
(let* ((entry (guix-list-current-entry))
(available (guix-get-key-val entry 'outputs))
(installed (guix-get-installed-outputs entry))
(to-install (if arg
(guix-completing-read-multiple
"Output(s) to install: " available nil t)
'("out")))
(to-install (cl-set-difference to-install installed
:test #'string=)))
(if to-install
(apply #'guix-list-mark 'install t to-install)
(user-error "This package is already installed"))))
(defun guix-package-list-mark-delete (&optional arg)
"Mark the current package for deletion and move to the next line.
With ARG, prompt for the outputs to delete (several outputs may
be separated with \",\")."
(interactive "P")
(guix-package-list-marking-check)
(let* ((entry (guix-list-current-entry))
(installed (guix-get-installed-outputs entry)))
(or installed
(user-error "This package is not installed"))
(let ((to-delete (when arg
(guix-completing-read-multiple
"Output(s) to delete: " installed nil t))))
(if to-delete
(apply #'guix-list-mark 'delete t to-delete)
(guix-package-list-mark-delete-simple)))))
(defun guix-package-list-mark-upgrade ()
"Mark the current package for upgrading and move to the next line."
(interactive)
(guix-package-list-marking-check)
(let ((entry (guix-list-current-entry)))
(or (guix-get-installed-outputs entry)
(user-error "This package is not installed"))
(when (or (guix-get-key-val entry 'obsolete)
(y-or-n-p "This package is not obsolete. Try to upgrade it anyway? "))
(guix-package-list-mark-upgrade-simple))))
(defun guix-package-list-execute ()
"Perform actions on the marked packages."
(interactive)
(let ((actions (delq nil
(mapcar #'guix-package-list-make-action
'(install delete upgrade)))))
(if actions
(apply #'guix-process-package-actions actions)
(user-error "No operations specified"))))
(defun guix-package-list-make-action (action-type)
"Return action specification for the packages marked with ACTION-TYPE.
Return nil, if there are no packages marked with ACTION-TYPE.
The specification is suitable for `guix-process-package-actions'."
(let ((specs (guix-list-get-marked-args action-type)))
(and specs (cons action-type specs))))
;;; Displaying generations
(guix-define-buffer-type list generation)
(guix-list-define-entry-type generation
:sort-key number
:invert-sort t
:marks ((delete . ?D)))
(let ((map guix-generation-list-mode-map))
(define-key map (kbd "RET") 'guix-generation-list-show-packages)
(define-key map (kbd "i") 'guix-generation-list-describe)
(define-key map (kbd "d") 'guix-generation-list-mark-delete-simple))
(defun guix-generation-list-show-packages ()
"List installed packages for the generation at point."
(interactive)
(guix-package-list-get-show 'generation (guix-list-current-id)))
(provide 'guix-list)
;;; guix-list.el ends here

603
emacs/guix-main.scm Normal file
View File

@ -0,0 +1,603 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Information about packages and generations is passed to the elisp
;; side in the form of alists of parameters (such as ‘name’ or
;; ‘version’) and their values. These alists are called "entries" in
;; this code. So to distinguish, just "package" in the name of a
;; function means a guile object ("package" record) while
;; "package entry" means alist of package parameters and values (see
;; ‘package-param-alist’).
;;
;; "Entry" is probably not the best name for such alists, because there
;; already exists "manifest-entry" which has nothing to do with the
;; "entry" described above. Do not be confused :)
;; ‘get-entries’ function is the “entry point” for the elisp side to get
;; information about packages and generations.
;; Since name/version pair is not necessarily unique, we use
;; `object-address' to identify a package (for ‘id’ parameter), if
;; possible. However for the obsolete packages (that can be found in
;; installed manifest but not in a package directory), ‘id’ parameter is
;; still "name-version" string. So ‘id’ package parameter in the code
;; below is either an object-address number or a full-name string.
;;
;; Important: as object addresses live only during guile session, elisp
;; part should take care about updating information after "Guix REPL" is
;; restarted (TODO!)
;;
;; ‘installed’ parameter of a package entry contains information about
;; installed outputs. It is a list of "installed entries" (see
;; ‘package-installed-param-alist’).
;; To speed-up the process of getting information, the following
;; auxiliary variables are used:
;;
;; - `%packages' - VHash of "package address"/"package" pairs.
;;
;; - `%package-table' - Hash table of
;; "name+version key"/"list of packages" pairs.
;;
;; - `%current-manifest-entries-table' - Hash table of
;; "name+version key"/"list of manifest entries" pairs. This variable
;; is set by `set-current-manifest-maybe!' when it is needed.
;;; Code:
(use-modules
(ice-9 vlist)
(ice-9 match)
(srfi srfi-1)
(srfi srfi-11)
(srfi srfi-19)
(srfi srfi-26)
(guix)
(guix packages)
(guix profiles)
(guix licenses)
(guix utils)
(guix ui)
(guix scripts package)
(gnu packages))
(define-syntax-rule (first-or-false lst)
(and (not (null? lst))
(first lst)))
(define full-name->name+version package-name->name+version)
(define (name+version->full-name name version)
(string-append name "-" version))
(define* (make-package-specification name #:optional version output)
(let ((full-name (if version
(name+version->full-name name version)
name)))
(if output
(string-append full-name ":" output)
full-name)))
(define name+version->key cons)
(define key->name+version car+cdr)
(define %current-manifest #f)
(define %current-manifest-entries-table #f)
(define %packages
(fold-packages (lambda (pkg res)
(vhash-consq (object-address pkg) pkg res))
vlist-null))
(define %package-table
(let ((table (make-hash-table (vlist-length %packages))))
(vlist-for-each
(lambda (elem)
(match elem
((address . pkg)
(let* ((key (name+version->key (package-name pkg)
(package-version pkg)))
(ref (hash-ref table key)))
(hash-set! table key
(if ref (cons pkg ref) (list pkg)))))))
%packages)
table))
;; FIXME get rid of this function!
(define (set-current-manifest-maybe! profile)
(define (manifest-entries->hash-table entries)
(let ((entries-table (make-hash-table (length entries))))
(for-each (lambda (entry)
(let* ((key (name+version->key
(manifest-entry-name entry)
(manifest-entry-version entry)))
(ref (hash-ref entries-table key)))
(hash-set! entries-table key
(if ref (cons entry ref) (list entry)))))
entries)
entries-table))
(when profile
(let ((manifest (profile-manifest profile)))
(unless (and (manifest? %current-manifest)
(equal? manifest %current-manifest))
(set! %current-manifest manifest)
(set! %current-manifest-entries-table
(manifest-entries->hash-table
(manifest-entries manifest)))))))
(define (manifest-entries-by-name+version name version)
(or (hash-ref %current-manifest-entries-table
(name+version->key name version))
'()))
(define (packages-by-name+version name version)
(or (hash-ref %package-table
(name+version->key name version))
'()))
(define (packages-by-full-name full-name)
(call-with-values
(lambda () (full-name->name+version full-name))
packages-by-name+version))
(define (package-by-address address)
(and=> (vhash-assq address %packages)
cdr))
(define (packages-by-id id)
(if (integer? id)
(let ((pkg (package-by-address id)))
(if pkg (list pkg) '()))
(packages-by-full-name id)))
(define (package-by-id id)
(first-or-false (packages-by-id id)))
(define (newest-package-by-id id)
(and=> (id->name+version id)
(lambda (name)
(first-or-false (find-best-packages-by-name name #f)))))
(define (id->name+version id)
(if (integer? id)
(and=> (package-by-address id)
(lambda (pkg)
(values (package-name pkg)
(package-version pkg))))
(full-name->name+version id)))
(define (fold-manifest-entries proc init)
"Fold over `%current-manifest-entries-table'.
Call (PROC NAME VERSION ENTRIES RESULT) for each element of the hash
table, using INIT as the initial value of RESULT."
(hash-fold (lambda (key entries res)
(let-values (((name version) (key->name+version key)))
(proc name version entries res)))
init
%current-manifest-entries-table))
(define (fold-object proc init obj)
(fold proc init
(if (list? obj) obj (list obj))))
(define* (object-transformer param-alist #:optional (params '()))
"Return function for transforming an object into alist of parameters/values.
PARAM-ALIST is alist of available object parameters (symbols) and functions
returning values of these parameters. Each function is called with object as
a single argument.
PARAMS is list of parameters from PARAM-ALIST that should be returned by a
resulting function. If PARAMS is not specified or is an empty list, use all
available parameters.
Example:
(let ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>))))
(number->alist (object-transformer alist '(plus1 mul2))))
(number->alist 8))
=>
((plus1 . 9) (mul2 . 16))
"
(let ((alist (let ((use-all-params (null? params)))
(filter-map (match-lambda
((param . fun)
(and (or use-all-params
(memq param params))
(cons param fun)))
(_ #f))
param-alist))))
(lambda (object)
(map (match-lambda
((param . fun)
(cons param (fun object))))
alist))))
(define package-installed-param-alist
(list
(cons 'output manifest-entry-output)
(cons 'path manifest-entry-item)
(cons 'dependencies manifest-entry-dependencies)))
(define manifest-entry->installed-entry
(object-transformer package-installed-param-alist))
(define (manifest-entries->installed-entries entries)
(map manifest-entry->installed-entry entries))
(define (installed-entries-by-name+version name version)
(manifest-entries->installed-entries
(manifest-entries-by-name+version name version)))
(define (installed-entries-by-package package)
(installed-entries-by-name+version (package-name package)
(package-version package)))
(define (package-inputs-names inputs)
"Return list of full names of the packages from package INPUTS."
(filter-map (match-lambda
((_ (? package? package))
(package-full-name package))
(_ #f))
inputs))
(define (package-license-names package)
"Return list of license names of the PACKAGE."
(fold-object (lambda (license res)
(if (license? license)
(cons (license-name license) res)
res))
'()
(package-license package)))
(define (package-unique? package)
"Return #t if PACKAGE is a single package with such name/version."
(null? (cdr (packages-by-name+version (package-name package)
(package-version package)))))
(define package-param-alist
(list
(cons 'id object-address)
(cons 'name package-name)
(cons 'version package-version)
(cons 'license package-license-names)
(cons 'synopsis package-synopsis)
(cons 'description package-description)
(cons 'home-url package-home-page)
(cons 'outputs package-outputs)
(cons 'non-unique (negate package-unique?))
(cons 'inputs (lambda (pkg) (package-inputs-names
(package-inputs pkg))))
(cons 'native-inputs (lambda (pkg) (package-inputs-names
(package-native-inputs pkg))))
(cons 'propagated-inputs (lambda (pkg) (package-inputs-names
(package-propagated-inputs pkg))))
(cons 'location (lambda (pkg) (location->string
(package-location pkg))))
(cons 'installed installed-entries-by-package)))
(define (package-param package param)
"Return the value of a PACKAGE PARAM."
(define (accessor param)
(and=> (assq param package-param-alist)
cdr))
(and=> (accessor param)
(cut <> package)))
(define (matching-package-entries ->entry predicate)
"Return list of package entries for the matching packages.
PREDICATE is called on each package."
(fold-packages (lambda (pkg res)
(if (predicate pkg)
(cons (->entry pkg) res)
res))
'()))
(define (make-obsolete-package-entry name version entries)
"Return package entry for an obsolete package with NAME and VERSION.
ENTRIES is a list of manifest entries used to get installed info."
`((id . ,(name+version->full-name name version))
(name . ,name)
(version . ,version)
(outputs . ,(map manifest-entry-output entries))
(obsolete . #t)
(installed . ,(manifest-entries->installed-entries entries))))
(define (package-entries-by-name+version ->entry name version)
"Return list of package entries for packages with NAME and VERSION."
(let ((packages (packages-by-name+version name version)))
(if (null? packages)
(let ((entries (manifest-entries-by-name+version name version)))
(if (null? entries)
'()
(list (make-obsolete-package-entry name version entries))))
(map ->entry packages))))
(define (package-entries-by-spec profile ->entry spec)
"Return list of package entries for packages with name specification SPEC."
(set-current-manifest-maybe! profile)
(let-values (((name version)
(full-name->name+version spec)))
(if version
(package-entries-by-name+version ->entry name version)
(matching-package-entries
->entry
(lambda (pkg) (string=? name (package-name pkg)))))))
(define (package-entries-by-regexp profile ->entry regexp match-params)
"Return list of package entries for packages matching REGEXP string.
MATCH-PARAMS is a list of parameters that REGEXP can match."
(define (package-match? package regexp)
(any (lambda (param)
(let ((val (package-param package param)))
(and (string? val) (regexp-exec regexp val))))
match-params))
(set-current-manifest-maybe! profile)
(let ((re (make-regexp regexp regexp/icase)))
(matching-package-entries ->entry (cut package-match? <> re))))
(define (package-entries-by-ids profile ->entry ids)
"Return list of package entries for packages matching KEYS.
IDS may be an object-address, a full-name or a list of such elements."
(set-current-manifest-maybe! profile)
(fold-object
(lambda (id res)
(if (integer? id)
(let ((pkg (package-by-address id)))
(if pkg
(cons (->entry pkg) res)
res))
(let ((entries (package-entries-by-spec #f ->entry id)))
(if (null? entries)
res
(append res entries)))))
'()
ids))
(define (newest-available-package-entries profile ->entry)
"Return list of package entries for the newest available packages."
(set-current-manifest-maybe! profile)
(vhash-fold (lambda (name elem res)
(match elem
((version newest pkgs ...)
(cons (->entry newest) res))))
'()
(find-newest-available-packages)))
(define (all-available-package-entries profile ->entry)
"Return list of package entries for all available packages."
(set-current-manifest-maybe! profile)
(matching-package-entries ->entry (const #t)))
(define (manifest-package-entries ->entry)
"Return list of package entries for the current manifest."
(fold-manifest-entries
(lambda (name version entries res)
;; We don't care about duplicates for the list of
;; installed packages, so just take any package (car)
;; matching name+version
(cons (car (package-entries-by-name+version ->entry name version))
res))
'()))
(define (installed-package-entries profile ->entry)
"Return list of package entries for all installed packages."
(set-current-manifest-maybe! profile)
(manifest-package-entries ->entry))
(define (generation-package-entries profile ->entry generation)
"Return list of package entries for packages from GENERATION."
(set-current-manifest-maybe!
(generation-file-name profile generation))
(manifest-package-entries ->entry))
(define (obsolete-package-entries profile _)
"Return list of package entries for obsolete packages."
(set-current-manifest-maybe! profile)
(fold-manifest-entries
(lambda (name version entries res)
(let ((packages (packages-by-name+version name version)))
(if (null? packages)
(cons (make-obsolete-package-entry name version entries) res)
res)))
'()))
;;; Generation entries
(define (profile-generations profile)
"Return list of generations for PROFILE."
(let ((generations (generation-numbers profile)))
(if (equal? generations '(0))
'()
generations)))
(define (generation-param-alist profile)
"Return alist of generation parameters and functions for PROFILE."
(list
(cons 'id identity)
(cons 'number identity)
(cons 'prev-number (cut previous-generation-number profile <>))
(cons 'path (cut generation-file-name profile <>))
(cons 'time (lambda (gen)
(time-second (generation-time profile gen))))))
(define (matching-generation-entries profile ->entry predicate)
"Return list of generation entries for the matching generations.
PREDICATE is called on each generation."
(filter-map (lambda (gen)
(and (predicate gen) (->entry gen)))
(profile-generations profile)))
(define (last-generation-entries profile ->entry number)
"Return list of last NUMBER generation entries.
If NUMBER is 0 or less, return all generation entries."
(let ((generations (profile-generations profile))
(number (if (<= number 0) +inf.0 number)))
(map ->entry
(if (> (length generations) number)
(list-head (reverse generations) number)
generations))))
(define (all-generation-entries profile ->entry)
"Return list of all generation entries."
(last-generation-entries profile ->entry +inf.0))
(define (generation-entries-by-ids profile ->entry ids)
"Return list of generation entries for generations matching IDS.
IDS is a list of generation numbers."
(matching-generation-entries profile ->entry (cut memq <> ids)))
;;; Getting package/generation entries
(define %package-entries-functions
(alist->vhash
`((id . ,package-entries-by-ids)
(name . ,package-entries-by-spec)
(regexp . ,package-entries-by-regexp)
(all-available . ,all-available-package-entries)
(newest-available . ,newest-available-package-entries)
(installed . ,installed-package-entries)
(obsolete . ,obsolete-package-entries)
(generation . ,generation-package-entries))
hashq))
(define %generation-entries-functions
(alist->vhash
`((id . ,generation-entries-by-ids)
(last . ,last-generation-entries)
(all . ,all-generation-entries))
hashq))
(define (get-entries profile params entry-type search-type search-vals)
"Return list of entries.
ENTRY-TYPE and SEARCH-TYPE define a search function that should be
applied to PARAMS and VALS."
(let-values (((vhash ->entry)
(case entry-type
((package)
(values %package-entries-functions
(object-transformer
package-param-alist params)))
((generation)
(values %generation-entries-functions
(object-transformer
(generation-param-alist profile) params)))
(else (format (current-error-port)
"Wrong entry type '~a'" entry-type)))))
(match (vhash-assq search-type vhash)
((key . fun)
(apply fun profile ->entry search-vals))
(_ '()))))
;;; Actions
(define* (package->manifest-entry* package #:optional output)
(and package
(begin
(check-package-freshness package)
(package->manifest-entry package output))))
(define* (make-install-manifest-entries id #:optional output)
(package->manifest-entry* (package-by-id id) output))
(define* (make-upgrade-manifest-entries id #:optional output)
(package->manifest-entry* (newest-package-by-id id) output))
(define* (make-manifest-pattern id #:optional output)
"Make manifest pattern from a package ID and OUTPUT."
(let-values (((name version)
(id->name+version id)))
(and name version
(manifest-pattern
(name name)
(version version)
(output output)))))
(define (convert-action-pattern pattern proc)
"Convert action PATTERN into a list of objects returned by PROC.
PROC is called: (PROC ID) or (PROC ID OUTPUT)."
(match pattern
((id . outputs)
(if (null? outputs)
(let ((obj (proc id)))
(if obj (list obj) '()))
(filter-map (cut proc id <>)
outputs)))
(_ '())))
(define (convert-action-patterns patterns proc)
(append-map (cut convert-action-pattern <> proc)
patterns))
(define* (process-package-actions
profile #:key (install '()) (upgrade '()) (remove '())
(use-substitutes? #t) dry-run?)
"Perform package actions.
INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'.
Each pattern should have the following form:
(ID . OUTPUTS)
ID is an object address or a full-name of a package.
OUTPUTS is a list of package outputs (may be an empty list)."
(format #t "The process begins ...~%")
(let* ((install (append
(convert-action-patterns
install make-install-manifest-entries)
(convert-action-patterns
upgrade make-upgrade-manifest-entries)))
(remove (convert-action-patterns remove make-manifest-pattern))
(transaction (manifest-transaction (install install)
(remove remove)))
(manifest (profile-manifest profile))
(new-manifest (manifest-perform-transaction
manifest transaction)))
(unless (and (null? install) (null? remove))
(let* ((store (open-connection))
(derivation (run-with-store
store (profile-derivation new-manifest)))
(derivations (list derivation))
(new-profile (derivation->output-path derivation)))
(set-build-options store
#:use-substitutes? use-substitutes?)
(manifest-show-transaction store manifest transaction
#:dry-run? dry-run?)
(show-what-to-build store derivations
#:use-substitutes? use-substitutes?
#:dry-run? dry-run?)
(unless dry-run?
(let ((name (generation-file-name
profile
(+ 1 (generation-number profile)))))
(and (build-derivations store derivations)
(let* ((entries (manifest-entries new-manifest))
(count (length entries)))
(switch-symlinks name new-profile)
(switch-symlinks profile name)
(format #t (N_ "~a package in profile~%"
"~a packages in profile~%"
count)
count)))))))))

160
emacs/guix-utils.el Normal file
View File

@ -0,0 +1,160 @@
;;; guix-utils.el --- General utility functions
;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;; This file is part of GNU Guix.
;; GNU Guix is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Guix is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides auxiliary general functions for guix.el package.
;;; Code:
;; (require 'cl-lib)
(defvar guix-true-string "Yes")
(defvar guix-false-string "–")
(defvar guix-list-separator ", ")
(defvar guix-time-format "%F %T"
"String used to format time values.
For possible formats, see `format-time-string'.")
(defun guix-get-string (val &optional face)
"Convert VAL into a string and return it.
VAL can be an expression of any type.
If VAL is t/nil, it is replaced with
`guix-true-string'/`guix-false-string'.
If VAL is list, its elements are concatenated using
`guix-list-separator'.
If FACE is non-nil, propertize returned string with this FACE."
(let ((str (cond
((stringp val) val)
((null val) guix-false-string)
((eq t val) guix-true-string)
((numberp val) (number-to-string val))
((listp val) (mapconcat #'guix-get-string
val guix-list-separator))
(t (prin1-to-string val)))))
(if (and val face)
(propertize str 'face face)
str)))
(defun guix-get-time-string (seconds)
"Return formatted time string from SECONDS.
Use `guix-time-format'."
(format-time-string guix-time-format (seconds-to-time seconds)))
(defun guix-get-one-line (str)
"Return one-line string from a multi-line STR."
(replace-regexp-in-string "\n" " " str))
(defun guix-format-insert (val &optional face format)
"Convert VAL into a string and insert it at point.
If FACE is non-nil, propertize VAL with FACE.
If FORMAT is non-nil, format VAL with FORMAT."
(let ((str (guix-get-string val face)))
(insert (if format
(format format str)
str))))
(defun guix-mapinsert (function sequence separator)
"Like `mapconcat' but for inserting text.
Apply FUNCTION to each element of SEQUENCE, and insert SEPARATOR
at point between each FUNCTION call."
(when sequence
(funcall function (car sequence))
(mapc (lambda (obj)
(insert separator)
(funcall function obj))
(cdr sequence))))
(defun guix-insert-button (label face action &optional message
&rest properties)
"Make button with LABEL and insert it at point.
Propertize button with FACE.
ACTION is a function called when the button is pressed. It
should accept button as the argument.
MESSAGE is a button message.
See `insert-text-button' for the meaning of PROPERTIES."
(if (null label)
(guix-format-insert nil)
(apply #'insert-text-button
label
'face face
'action action
'follow-link t
'help-echo message
properties)))
(defun guix-split-insert (val &optional face col separator)
"Convert VAL into a string, split it and insert at point.
If FACE is non-nil, propertize returned string with this FACE.
If COL is non-nil and result string is a one-line string longer
than COL, split it into several short lines.
Separate inserted lines with SEPARATOR."
(if (null val)
(guix-format-insert nil)
(let ((strings (guix-split-string (guix-get-string val) col)))
(guix-mapinsert (lambda (str) (guix-format-insert str face))
strings
(or separator "")))))
(defun guix-split-string (str &optional col)
"Split string STR by lines and return list of result strings.
If COL is non-nil and STR is a one-line string longer than COL,
split it into several short lines."
(let ((strings (split-string str "\n *")))
(if (and col
(null (cdr strings)) ; if not multi-line
(> (length str) col))
(split-string (guix-get-filled-string str col) "\n")
strings)))
(defun guix-get-filled-string (str col)
"Return string by filling STR to column COL."
(with-temp-buffer
(insert str)
(let ((fill-column col))
(fill-region (point-min) (point-max)))
(buffer-string)))
(defun guix-completing-read-multiple (prompt table &optional predicate
require-match initial-input
hist def inherit-input-method)
"Same as `completing-read-multiple' but remove duplicates in result."
(cl-remove-duplicates
(completing-read-multiple prompt table predicate
require-match initial-input
hist def inherit-input-method)
:test #'string=))
(defun guix-get-key-val (alist &rest keys)
"Return value from ALIST by KEYS.
ALIST is alist of alists of alists ... which can be consecutively
accessed with KEYS."
(let ((val alist))
(dolist (key keys val)
(setq val (cdr (assq key val))))))
(provide 'guix-utils)
;;; guix-utils.el ends here

141
emacs/guix.el Normal file
View File

@ -0,0 +1,141 @@
;;; guix.el --- Interface for GNU Guix package manager
;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;; Package-Requires: ((geiser "0.3"))
;; Keywords: tools
;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This package provides an interface for searching, listing and getting
;; information about Guix packages and generations; and for
;; installing/upgrading/removing packages.
;;; Code:
(require 'guix-list)
(require 'guix-info)
(defgroup guix nil
"Interface for Guix package manager."
:prefix "guix-"
:group 'external)
(defcustom guix-list-single-package nil
"If non-nil, list a package even if it is the only matching result.
If nil, show a single package in the info buffer."
:type 'boolean
:group 'guix)
(defcustom guix-show-generations-function 'guix-generation-list-get-show
"Default function used to display generations."
:type '(choice (function-item guix-generation-list-get-show)
(function-item guix-generation-info-get-show))
:group 'guix)
(defvar guix-search-params '(name synopsis description)
"Default list of package parameters for searching by regexp.")
(defvar guix-search-history nil
"A history of minibuffer prompts.")
(defun guix-get-show-packages (search-type &rest search-vals)
"Search for packages and show results.
See `guix-get-entries' for the meaning of SEARCH-TYPE and
SEARCH-VALS.
Results are displayed in the list buffer, unless a single package
is found and `guix-list-single-package' is nil."
(let* ((list-params (guix-package-list-get-params-for-receiving))
(packages (guix-get-entries 'package search-type
search-vals list-params)))
(if (or guix-list-single-package
(cdr packages))
(guix-package-list-set packages search-type search-vals)
(let ((info-params (guix-package-info-get-params-for-receiving)))
(unless (equal list-params info-params)
;; If we don't have required info, we should receive it again
(setq packages (guix-get-entries 'package search-type
search-vals info-params))))
(guix-package-info-set packages search-type search-vals))))
(defun guix-get-show-generations (search-type &rest search-vals)
"Search for generations and show results."
(apply guix-show-generations-function search-type search-vals))
;;;###autoload
(defun guix-search-by-name (name)
"Search for Guix packages by NAME.
NAME is a string with name specification. It may optionally contain
a version number. Examples: \"guile\", \"guile-2.0.11\"."
(interactive
(list (read-string "Package name: " nil 'guix-search-history)))
(guix-get-show-packages 'name name))
;;;###autoload
(defun guix-search-by-regexp (regexp &rest params)
"Search for Guix packages by REGEXP.
PARAMS are package parameters that should be searched.
If PARAMS are not specified, use `guix-search-params'."
(interactive
(list (read-string "Regexp: " nil 'guix-search-history)))
(or params (setq params guix-search-params))
(guix-get-show-packages 'regexp regexp params))
;;;###autoload
(defun guix-installed-packages ()
"Display information about installed Guix packages."
(interactive)
(guix-get-show-packages 'installed))
;;;###autoload
(defun guix-obsolete-packages ()
"Display information about obsolete Guix packages."
(interactive)
(guix-get-show-packages 'obsolete))
;;;###autoload
(defun guix-all-available-packages ()
"Display information about all available Guix packages."
(interactive)
(guix-get-show-packages 'all-available))
;;;###autoload
(defun guix-newest-available-packages ()
"Display information about the newest available Guix packages."
(interactive)
(guix-get-show-packages 'newest-available))
;;;###autoload
(defun guix-generations (&optional number)
"Display information about last NUMBER generations.
If NUMBER is nil, display all generations.
Generations can be displayed in a list or info buffers depending
on `guix-show-generations-function'.
Interactively, NUMBER is defined by a numeric prefix."
(interactive "P")
(if (numberp number)
(guix-get-show-generations 'last number)
(guix-get-show-generations 'all)))
(provide 'guix)
;;; guix.el ends here

19
gnu-system.am
View File

@ -28,7 +28,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/acl.scm \
gnu/packages/admin.scm \
gnu/packages/algebra.scm \
gnu/packages/aidc.scm \
gnu/packages/aidc.scm \
gnu/packages/apl.scm \
gnu/packages/apr.scm \
gnu/packages/asciidoc.scm \
@ -58,7 +58,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/compression.scm \
gnu/packages/complexity.scm \
gnu/packages/conkeror.scm \
gnu/packages/cook.scm \
gnu/packages/cook.scm \
gnu/packages/cpio.scm \
gnu/packages/cppi.scm \
gnu/packages/cross-base.scm \
@ -151,7 +151,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/lightning.scm \
gnu/packages/links.scm \
gnu/packages/linux.scm \
gnu/packages/lisp.scm \
gnu/packages/lisp.scm \
gnu/packages/lout.scm \
gnu/packages/lsh.scm \
gnu/packages/lsof.scm \
@ -180,6 +180,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/nettle.scm \
gnu/packages/node.scm \
gnu/packages/noweb.scm \
gnu/packages/nvi.scm \
gnu/packages/ocaml.scm \
gnu/packages/ocrad.scm \
gnu/packages/onc-rpc.scm \
@ -198,6 +199,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/pkg-config.scm \
gnu/packages/plotutils.scm \
gnu/packages/popt.scm \
gnu/packages/postgresql.scm \
gnu/packages/pth.scm \
gnu/packages/pulseaudio.scm \
gnu/packages/pretty-print.scm \
@ -275,7 +277,15 @@ GNU_SYSTEM_MODULES = \
gnu/system/linux.scm \
gnu/system/linux-initrd.scm \
gnu/system/shadow.scm \
gnu/system/vm.scm
gnu/system/vm.scm \
\
gnu/build/activation.scm \
gnu/build/file-systems.scm \
gnu/build/install.scm \
gnu/build/linux-boot.scm \
gnu/build/linux-initrd.scm \
gnu/build/vm.scm
patchdir = $(guilemoduledir)/gnu/packages/patches
dist_patch_DATA = \
@ -351,6 +361,7 @@ dist_patch_DATA = \
gnu/packages/patches/mit-krb5-init-fix.patch \
gnu/packages/patches/mpc123-initialize-ao.patch \
gnu/packages/patches/module-init-tools-moduledir.patch \
gnu/packages/patches/nvi-assume-preserve-path.patch \
gnu/packages/patches/orpheus-cast-errors-and-includes.patch \
gnu/packages/patches/patchelf-page-size.patch \
gnu/packages/patches/patchutils-xfail-gendiff-tests.patch \

4
guix/build/activation.scm → gnu/build/activation.scm
View File

@ -16,9 +16,9 @@
;;; 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 (guix build activation)
(define-module (gnu build activation)
#:use-module (gnu build linux-boot)
#:use-module (guix build utils)
#:use-module (guix build linux-initrd)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)

299
gnu/build/file-systems.scm Normal file
View File

@ -0,0 +1,299 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build file-systems)
#:use-module (guix build utils)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (system foreign)
#:autoload (system repl repl) (start-repl)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (disk-partitions
partition-label-predicate
find-partition-by-label
canonicalize-device-spec
MS_RDONLY
MS_NOSUID
MS_NODEV
MS_NOEXEC
MS_BIND
MS_MOVE
bind-mount
mount-flags->bit-mask
check-file-system
mount-file-system))
;;; Commentary:
;;;
;;; This modules provides tools to deal with disk partitions, and to mount and
;;; check file systems.
;;;
;;; Code:
;; Linux mount flags, from libc's <sys/mount.h>.
(define MS_RDONLY 1)
(define MS_NOSUID 2)
(define MS_NODEV 4)
(define MS_NOEXEC 8)
(define MS_BIND 4096)
(define MS_MOVE 8192)
(define (bind-mount source target)
"Bind-mount SOURCE at TARGET."
(mount source target "" MS_BIND))
(define-syntax %ext2-endianness
;; Endianness of ext2 file systems.
(identifier-syntax (endianness little)))
;; Offset in bytes of interesting parts of an ext2 superblock. See
;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
;; TODO: Use "packed structs" from Guile-OpenGL or similar.
(define-syntax %ext2-sblock-magic (identifier-syntax 56))
(define-syntax %ext2-sblock-creator-os (identifier-syntax 72))
(define-syntax %ext2-sblock-uuid (identifier-syntax 104))
(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
(define (read-ext2-superblock device)
"Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
if DEVICE does not contain an ext2 file system."
(define %ext2-magic
;; The magic bytes that identify an ext2 file system.
#xef53)
(define superblock-size
;; Size of the interesting part of an ext2 superblock.
264)
(define block
;; The superblock contents.
(make-bytevector superblock-size))
(call-with-input-file device
(lambda (port)
(seek port 1024 SEEK_SET)
;; Note: work around <http://bugs.gnu.org/17466>.
(and (eqv? superblock-size (get-bytevector-n! port block 0
superblock-size))
(let ((magic (bytevector-u16-ref block %ext2-sblock-magic
%ext2-endianness)))
(and (= magic %ext2-magic)
block))))))
(define (ext2-superblock-uuid sblock)
"Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
(let ((uuid (make-bytevector 16)))
(bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
uuid))
(define (ext2-superblock-volume-name sblock)
"Return the volume name of SBLOCK as a string of at most 16 characters, or
#f if SBLOCK has no volume name."
(let ((bv (make-bytevector 16)))
(bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
;; This is a Latin-1, nul-terminated string.
(let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
(if (null? bytes)
#f
(list->string (map integer->char bytes))))))
(define (disk-partitions)
"Return the list of device names corresponding to valid disk partitions."
(define (partition? major minor)
(let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
(catch 'system-error
(lambda ()
(not (zero? (call-with-input-file marker read))))
(lambda args
(if (= ENOENT (system-error-errno args))
#f
(apply throw args))))))
(call-with-input-file "/proc/partitions"
(lambda (port)
;; Skip the two header lines.
(read-line port)
(read-line port)
;; Read each subsequent line, and extract the last space-separated
;; field.
(let loop ((parts '()))
(let ((line (read-line port)))
(if (eof-object? line)
(reverse parts)
(match (string-tokenize line)
(((= string->number major) (= string->number minor)
blocks name)
(if (partition? major minor)
(loop (cons name parts))
(loop parts))))))))))
(define (partition-label-predicate label)
"Return a procedure that, when applied to a partition name such as \"sda1\",
return #t if that partition's volume name is LABEL."
(lambda (part)
(let* ((device (string-append "/dev/" part))
(sblock (catch 'system-error
(lambda ()
(read-ext2-superblock device))
(lambda args
;; When running on the hand-made /dev,
;; 'disk-partitions' could return partitions for which
;; we have no /dev node. Handle that gracefully.
(if (= ENOENT (system-error-errno args))
(begin
(format (current-error-port)
"warning: device '~a' not found~%"
device)
#f)
(apply throw args))))))
(and sblock
(let ((volume (ext2-superblock-volume-name sblock)))
(and volume
(string=? volume label)))))))
(define (find-partition-by-label label)
"Return the first partition found whose volume name is LABEL, or #f if none
were found."
(and=> (find (partition-label-predicate label)
(disk-partitions))
(cut string-append "/dev/" <>)))
(define* (canonicalize-device-spec spec #:optional (title 'any))
"Return the device name corresponding to SPEC. TITLE is a symbol, one of
the following:
• 'device', in which case SPEC is known to designate a device node--e.g.,
\"/dev/sda1\";
• 'label', in which case SPEC is known to designate a partition label--e.g.,
\"my-root-part\";
• 'any', in which case SPEC can be anything.
"
(define max-trials
;; Number of times we retry partition label resolution, 1 second per
;; trial. Note: somebody reported a delay of 16 seconds (!) before their
;; USB key would be detected by the kernel, so we must wait for at least
;; this long.
20)
(define canonical-title
;; The realm of canonicalization.
(if (eq? title 'any)
(if (string-prefix? "/" spec)
'device
'label)
title))
(case canonical-title
((device)
;; Nothing to do.
spec)
((label)
;; Resolve the label.
(let loop ((count 0))
(let ((device (find-partition-by-label spec)))
(or device
;; Some devices take a bit of time to appear, most notably USB
;; storage devices. Thus, wait for the device to appear.
(if (> count max-trials)
(error "failed to resolve partition label" spec)
(begin
(format #t "waiting for partition '~a' to appear...~%"
spec)
(sleep 1)
(loop (+ 1 count))))))))
;; TODO: Add support for UUIDs.
(else
(error "unknown device title" title))))
(define (check-file-system device type)
"Run a file system check of TYPE on DEVICE."
(define fsck
(string-append "fsck." type))
(let ((status (system* fsck "-v" "-p" device)))
(match (status:exit-val status)
(0
#t)
(1
(format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
fsck device))
(2
(format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
fsck device)
(sleep 3)
(reboot))
(code
(format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
fsck code device)
(start-repl)))))
(define (mount-flags->bit-mask flags)
"Return the number suitable for the 'flags' argument of 'mount' that
corresponds to the symbols listed in FLAGS."
(let loop ((flags flags))
(match flags
(('read-only rest ...)
(logior MS_RDONLY (loop rest)))
(('bind-mount rest ...)
(logior MS_BIND (loop rest)))
(('no-suid rest ...)
(logior MS_NOSUID (loop rest)))
(('no-dev rest ...)
(logior MS_NODEV (loop rest)))
(('no-exec rest ...)
(logior MS_NOEXEC (loop rest)))
(()
0))))
(define* (mount-file-system spec #:key (root "/root"))
"Mount the file system described by SPEC under ROOT. SPEC must have the
form:
(DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
run a file system check."
(match spec
((source title mount-point type (flags ...) options check?)
(let ((source (canonicalize-device-spec source title))
(mount-point (string-append root "/" mount-point)))
(when check?
(check-file-system source type))
(mkdir-p mount-point)
(mount source mount-point type (mount-flags->bit-mask flags)
(if options
(string->pointer options)
%null-pointer))
;; Update /etc/mtab.
(mkdir-p (string-append root "/etc"))
(let ((port (open-file (string-append root "/etc/mtab") "a")))
(format port "~a ~a ~a ~a 0 0~%"
source mount-point type (or options ""))
(close-port port))))))
;;; file-systems.scm ends here

3
guix/build/install.scm → gnu/build/install.scm
View File

@ -16,9 +16,8 @@
;;; 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 (guix build install)
(define-module (gnu build install)
#:use-module (guix build utils)
#:use-module (guix build install)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (install-grub

261
guix/build/linux-initrd.scm → gnu/build/linux-boot.scm
View File

@ -16,35 +16,24 @@
;;; 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 (guix build linux-initrd)
(define-module (gnu build linux-boot)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
#:use-module (system repl error-handling)
#:autoload (system repl repl) (start-repl)
#:autoload (system base compile) (compile-file)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 ftw)
#:use-module (guix build utils)
#:use-module (gnu build file-systems)
#:export (mount-essential-file-systems
linux-command-line
find-long-option
make-essential-device-nodes
configure-qemu-networking
disk-partitions
partition-label-predicate
find-partition-by-label
canonicalize-device-spec
mount-flags->bit-mask
check-file-system
mount-file-system
bind-mount
load-linux-module*
device-number
boot-system))
@ -99,172 +88,6 @@ Return the value associated with OPTION, or #f on failure."
(lambda (arg)
(substring arg (+ 1 (string-index arg #\=)))))))
(define-syntax %ext2-endianness
;; Endianness of ext2 file systems.
(identifier-syntax (endianness little)))
;; Offset in bytes of interesting parts of an ext2 superblock. See
;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
;; TODO: Use "packed structs" from Guile-OpenGL or similar.
(define-syntax %ext2-sblock-magic (identifier-syntax 56))
(define-syntax %ext2-sblock-creator-os (identifier-syntax 72))
(define-syntax %ext2-sblock-uuid (identifier-syntax 104))
(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
(define (read-ext2-superblock device)
"Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
if DEVICE does not contain an ext2 file system."
(define %ext2-magic
;; The magic bytes that identify an ext2 file system.
#xef53)
(define superblock-size
;; Size of the interesting part of an ext2 superblock.
264)
(define block
;; The superblock contents.
(make-bytevector superblock-size))
(call-with-input-file device
(lambda (port)
(seek port 1024 SEEK_SET)
;; Note: work around <http://bugs.gnu.org/17466>.
(and (eqv? superblock-size (get-bytevector-n! port block 0
superblock-size))
(let ((magic (bytevector-u16-ref block %ext2-sblock-magic
%ext2-endianness)))
(and (= magic %ext2-magic)
block))))))
(define (ext2-superblock-uuid sblock)
"Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
(let ((uuid (make-bytevector 16)))
(bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
uuid))
(define (ext2-superblock-volume-name sblock)
"Return the volume name of SBLOCK as a string of at most 16 characters, or
#f if SBLOCK has no volume name."
(let ((bv (make-bytevector 16)))
(bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
;; This is a Latin-1, nul-terminated string.
(let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
(if (null? bytes)
#f
(list->string (map integer->char bytes))))))
(define (disk-partitions)
"Return the list of device names corresponding to valid disk partitions."
(define (partition? major minor)
(let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
(catch 'system-error
(lambda ()
(not (zero? (call-with-input-file marker read))))
(lambda args
(if (= ENOENT (system-error-errno args))
#f
(apply throw args))))))
(call-with-input-file "/proc/partitions"
(lambda (port)
;; Skip the two header lines.
(read-line port)
(read-line port)
;; Read each subsequent line, and extract the last space-separated
;; field.
(let loop ((parts '()))
(let ((line (read-line port)))
(if (eof-object? line)
(reverse parts)
(match (string-tokenize line)
(((= string->number major) (= string->number minor)
blocks name)
(if (partition? major minor)
(loop (cons name parts))
(loop parts))))))))))
(define (partition-label-predicate label)
"Return a procedure that, when applied to a partition name such as \"sda1\",
return #t if that partition's volume name is LABEL."
(lambda (part)
(let* ((device (string-append "/dev/" part))
(sblock (catch 'system-error
(lambda ()
(read-ext2-superblock device))
(lambda args
;; When running on the hand-made /dev,
;; 'disk-partitions' could return partitions for which
;; we have no /dev node. Handle that gracefully.
(if (= ENOENT (system-error-errno args))
(begin
(format (current-error-port)
"warning: device '~a' not found~%"
device)
#f)
(apply throw args))))))
(and sblock
(let ((volume (ext2-superblock-volume-name sblock)))
(and volume
(string=? volume label)))))))
(define (find-partition-by-label label)
"Return the first partition found whose volume name is LABEL, or #f if none
were found."
(and=> (find (partition-label-predicate label)
(disk-partitions))
(cut string-append "/dev/" <>)))
(define* (canonicalize-device-spec spec #:optional (title 'any))
"Return the device name corresponding to SPEC. TITLE is a symbol, one of
the following:
• 'device', in which case SPEC is known to designate a device node--e.g.,
\"/dev/sda1\";
• 'label', in which case SPEC is known to designate a partition label--e.g.,
\"my-root-part\";
• 'any', in which case SPEC can be anything.
"
(define max-trials
;; Number of times we retry partition label resolution, 1 second per
;; trial. Note: somebody reported a delay of 16 seconds (!) before their
;; USB key would be detected by the kernel, so we must wait for at least
;; this long.
20)
(define canonical-title
;; The realm of canonicalization.
(if (eq? title 'any)
(if (string-prefix? "/" spec)
'device
'label)
title))
(case canonical-title
((device)
;; Nothing to do.
spec)
((label)
;; Resolve the label.
(let loop ((count 0))
(let ((device (find-partition-by-label spec)))
(or device
;; Some devices take a bit of time to appear, most notably USB
;; storage devices. Thus, wait for the device to appear.
(if (> count max-trials)
(error "failed to resolve partition label" spec)
(begin
(format #t "waiting for partition '~a' to appear...~%"
spec)
(sleep 1)
(loop (+ 1 count))))))))
;; TODO: Add support for UUIDs.
(else
(error "unknown device title" title))))
(define* (make-disk-device-nodes base major #:optional (minor 0))
"Make the block device nodes around BASE (something like \"/root/dev/sda\")
with the given MAJOR number, starting with MINOR."
@ -395,18 +218,6 @@ networking values.) Return #t if INTERFACE is up, #f otherwise."
(logand (network-interface-flags sock interface) IFF_UP)))
;; Linux mount flags, from libc's <sys/mount.h>.
(define MS_RDONLY 1)
(define MS_NOSUID 2)
(define MS_NODEV 4)
(define MS_NOEXEC 8)
(define MS_BIND 4096)
(define MS_MOVE 8192)
(define (bind-mount source target)
"Bind-mount SOURCE at TARGET."
(mount source target "" MS_BIND))
(define (load-linux-module* file)
"Load Linux module from FILE, the name of a `.ko' file."
(define (slurp module)
@ -479,74 +290,6 @@ UNIONFS."
(copy-file "/proc/mounts" "/root/etc/mtab"))
(define (check-file-system device type)
"Run a file system check of TYPE on DEVICE."
(define fsck
(string-append "fsck." type))
(let ((status (system* fsck "-v" "-p" device)))
(match (status:exit-val status)
(0
#t)
(1
(format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
fsck device))
(2
(format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
fsck device)
(sleep 3)
(reboot))
(code
(format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
fsck code device)
(start-repl)))))
(define (mount-flags->bit-mask flags)
"Return the number suitable for the 'flags' argument of 'mount' that
corresponds to the symbols listed in FLAGS."
(let loop ((flags flags))
(match flags
(('read-only rest ...)
(logior MS_RDONLY (loop rest)))
(('bind-mount rest ...)
(logior MS_BIND (loop rest)))
(('no-suid rest ...)
(logior MS_NOSUID (loop rest)))
(('no-dev rest ...)
(logior MS_NODEV (loop rest)))
(('no-exec rest ...)
(logior MS_NOEXEC (loop rest)))
(()
0))))
(define* (mount-file-system spec #:key (root "/root"))
"Mount the file system described by SPEC under ROOT. SPEC must have the
form:
(DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
run a file system check."
(match spec
((source title mount-point type (flags ...) options check?)
(let ((source (canonicalize-device-spec source title))
(mount-point (string-append root "/" mount-point)))
(when check?
(check-file-system source type))
(mkdir-p mount-point)
(mount source mount-point type (mount-flags->bit-mask flags)
(if options
(string->pointer options)
%null-pointer))
;; Update /etc/mtab.
(mkdir-p (string-append root "/etc"))
(let ((port (open-file (string-append root "/etc/mtab") "a")))
(format port "~a ~a ~a ~a 0 0~%"
source mount-point type (or options ""))
(close-port port))))))
(define (switch-root root)
"Switch to ROOT as the root file system, in a way similar to what
util-linux' switch_root(8) does."

72
gnu/build/linux-initrd.scm Normal file
View File

@ -0,0 +1,72 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build linux-initrd)
#:use-module (ice-9 popen)
#:use-module (ice-9 ftw)
#:export (write-cpio-archive))
;;; Commentary:
;;;
;;; Tools to create Linux initial RAM disks ("initrds"). Initrds are
;;; essentially gzipped cpio archives, with a '/init' executable that the
;;; kernel runs at boot time.
;;;
;;; Code:
(define* (write-cpio-archive output directory
#:key
(compress? #t)
(cpio "cpio") (gzip "gzip"))
"Write a cpio archive containing DIRECTORY to file OUTPUT, using CPIO. When
COMPRESS? is true, compress it using GZIP. On success, return OUTPUT."
;; Note: don't use '--no-absolute-filenames' since that strips leading
;; slashes from symlink targets.
(let ((pipe (open-pipe* OPEN_WRITE cpio "-o" "-O" output
"-H" "newc" "--null")))
(define (print0 file)
(format pipe "~a\0" file))
;; Note: as per `ramfs-rootfs-initramfs.txt', always add directory entries
;; before the files that are inside of it: "The Linux kernel cpio
;; extractor won't create files in a directory that doesn't exist, so the
;; directory entries must go before the files that go in those
;; directories."
;; XXX: Use a deterministic order.
(file-system-fold (const #t)
(lambda (file stat result) ; leaf
(print0 file))
(lambda (dir stat result) ; down
(unless (string=? dir directory)
(print0 dir)))
(const #f) ; up
(const #f) ; skip
(const #f)
#f
directory)
(and (zero? (close-pipe pipe))
(or (not compress?)
(and (zero? (system* gzip "--best" output))
(rename-file (string-append output ".gz")
output))
output))))
;;; linux-initrd.scm ends here

43
guix/build/vm.scm → gnu/build/vm.scm
View File

@ -16,14 +16,13 @@
;;; 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 (guix build vm)
(define-module (gnu build vm)
#:use-module (guix build utils)
#:use-module (guix build linux-initrd)
#:use-module (guix build install)
#:use-module (guix build store-copy)
#:use-module (gnu build linux-boot)
#:use-module (gnu build install)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (qemu-command
load-in-linux-vm
@ -111,20 +110,6 @@ the #:references-graphs parameter of 'derivation'."
(mkdir output)
(copy-recursively "xchg" output))))
(define (read-reference-graph port)
"Return a list of store paths from the reference graph at PORT.
The data at PORT is the format produced by #:references-graphs."
(let loop ((line (read-line port))
(result '()))
(cond ((eof-object? line)
(delete-duplicates result))
((string-prefix? "/" line)
(loop (read-line port)
(cons line result)))
(else
(loop (read-line port)
result)))))
(define* (initialize-partition-table device partition-size
#:key
(label-type "msdos")
@ -140,26 +125,6 @@ success."
(format #f "~aB" partition-size)))
(error "failed to create partition table")))
(define* (populate-store reference-graphs target)
"Populate the store under directory TARGET with the items specified in
REFERENCE-GRAPHS, a list of reference-graph files."
(define store
(string-append target (%store-directory)))
(define (things-to-copy)
;; Return the list of store files to copy to the image.
(define (graph-from-file file)
(call-with-input-file file read-reference-graph))
(delete-duplicates (append-map graph-from-file reference-graphs)))
(mkdir-p store)
(chmod store #o1775)
(for-each (lambda (thing)
(copy-recursively thing
(string-append target thing)))
(things-to-copy)))
(define MS_BIND 4096) ; <sys/mounts.h> again!
(define* (format-partition partition type

26
gnu/packages.scm
View File

@ -28,6 +28,7 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-39)
#:export (search-patch
@ -45,7 +46,9 @@
package-transitive-dependents
package-covering-dependents
check-package-freshness))
check-package-freshness
specification->package))
;;; Commentary:
;;;
@ -326,3 +329,24 @@ but ~a is available upstream~%")
(case key
((getaddrinfo-error ftp-error) #f)
(else (apply throw key args))))))
(define (specification->package spec)
"Return a package matching SPEC. SPEC may be a package name, or a package
name followed by a hyphen and a version number. If the version number is not
present, return the preferred newest version."
(let-values (((name version)
(package-name->name+version spec)))
(match (find-best-packages-by-name name version)
((p) ; one match
p)
((p x ...) ; several matches
(warning (_ "ambiguous package specification `~a'~%") spec)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
p)
(_ ; no matches
(if version
(leave (_ "~A: package not found for version ~a~%")
name version)
(leave (_ "~A: unknown package~%") name))))))

22
gnu/packages/avahi.scm
View File

@ -68,3 +68,25 @@
network. It is an implementation of the mDNS (for \"Multicast DNS\") and
DNS-SD (for \"DNS-Based Service Discovery\") protocols.")
(license lgpl2.1+)))
(define-public nss-mdns
(package
(name "nss-mdns")
(version "0.10")
(source (origin
(method url-fetch)
(uri (string-append
"http://0pointer.de/lennart/projects/nss-mdns/nss-mdns-"
version ".tar.gz"))
(sha256
(base32
"0vgs6j0qsl0mwzh5a0m0bykr7x6bx79vnbyn0r3q289rghp3qs0y"))))
(build-system gnu-build-system)
(home-page "http://0pointer.de/lennart/projects/nss-mdns/")
(synopsis "The mDNS Name Service Switch (NSS) plug-in")
(description
"'nss-mdns' is a plug-in for the Name Service Switch (NSS) functionality
of the GNU C Library, providing host name resolution via Multicast DNS (mDNS).
It allows for name resolution by programs in the ad-hoc mDNS domain
'.local'.")
(license lgpl2.1+)))

4
gnu/packages/commencement.scm
View File

@ -744,6 +744,10 @@ COREUTILS-FINAL vs. COREUTILS, etc."
(union-build (assoc-ref %outputs "debug")
(list (assoc-ref %build-inputs
"libc-debug"))))))
(native-search-paths (package-native-search-paths gcc))
(search-paths (package-search-paths gcc))
(license (package-license gcc))
(synopsis "Complete GCC tool chain for C/C++ development")
(description

6
gnu/packages/datamash.scm
View File

@ -27,7 +27,7 @@
(define-public datamash
(package
(name "datamash")
(version "1.0.5")
(version "1.0.6")
(source
(origin
(method url-fetch)
@ -35,7 +35,7 @@
version ".tar.gz"))
(sha256
(base32
"0f4rbbhl18fb851npza9cl8biynzr081f37ih2xsbvjlyrxhnz6b"))))
"0621a1xyf8gvcks0vb26g72dm4zh1s6y3a4cc5nnnl5m8mfc4m01"))))
(native-inputs
`(("which" ,which) ;for tests
("perl" ,perl))) ;for help2man
@ -45,4 +45,4 @@
(description
"Perform basic numeric, textual and statistical operations on plain text
files. Designed to work within standard pipelines without additional code.")
(license gpl3)))
(license gpl3+)))

4
gnu/packages/gnutls.scm
View File

@ -36,7 +36,7 @@
(define-public libtasn1
(package
(name "libtasn1")
(version "3.6")
(version "4.1")
(source
(origin
(method url-fetch)
@ -44,7 +44,7 @@
version ".tar.gz"))
(sha256
(base32
"0c547qa1vfk1x2jzgjhf65izf4sfi86c6g46q7779g4aldk4gqqr"))))
"00gkyppzw6fqi5mnc3d8paf7bp6nfhi9213481awy07sviqnbvk0"))))
(build-system gnu-build-system)
(native-inputs `(("perl" ,perl)

15
gnu/packages/linux.scm
View File

@ -189,7 +189,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM."
#f)))
(define-public linux-libre
(let* ((version "3.16.1")
(let* ((version "3.16.2")
(build-phase
'(lambda* (#:key system inputs #:allow-other-keys #:rest args)
;; Apply the neat patch.
@ -262,7 +262,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM."
(uri (linux-libre-urls version))
(sha256
(base32
"1x4y0017l4ndcab4smky2wx0n86r3wyks2r8yyp19ia9ccnl98mf"))))
"1p08cqy6427yi808fpbwbb4zbwhnkibj2i1wbrfa5rjhd4vnnffz"))))
(build-system gnu-build-system)
(native-inputs `(("perl" ,perl)
("bc" ,bc)
@ -1092,7 +1092,16 @@ UnionFS-FUSE additionally supports copy-on-write.")
libs " dl)"))))))
(arguments
'(#:tests? #f
#:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static")))
#:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static")
#:phases (alist-cons-after
'install 'post-install
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(exe (string-append out "/bin/unionfs")))
;; By default, 'unionfs' keeps references to
;; $glibc/share/locale and similar stuff. Remove them.
(remove-store-references exe)))
%standard-phases)))
(inputs `(("fuse" ,fuse-static)))))
(define-public sshfs-fuse

4
gnu/packages/man.scm
View File

@ -145,7 +145,7 @@ Linux kernel and C library interfaces employed by user-space programs.")
(define-public help2man
(package
(name "help2man")
(version "1.45.1")
(version "1.46.1")
(source
(origin
(method url-fetch)
@ -153,7 +153,7 @@ Linux kernel and C library interfaces employed by user-space programs.")
version ".tar.xz"))
(sha256
(base32
"1hk7ciqinq7djdb7s94y3jxh06rp8i93bpjmg4r40cniws8wf3y7"))))
"0iqwb3qirl7rp1wwpbh01q89qxvi4h3bc73wi03av6hl4sh05z9x"))))
(build-system gnu-build-system)
(arguments `(;; There's no `check' target.
#:tests? #f))

68
gnu/packages/nvi.scm Normal file
View File

@ -0,0 +1,68 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Marek Benc <merkur32@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu packages nvi)
#:use-module (gnu packages)
#:use-module (gnu packages bdb)
#:use-module (gnu packages ncurses)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (guix licenses))
(define-public nvi
(package
(name "nvi")
(version "1.81.6")
(source
(origin
(method url-fetch)
(uri ;; sites.google.coma/bostic.com/keithbostic/vi is stale.
(string-append "http://harrier.slackbuilds.org/misc/nvi-" version
".tar.bz2"))
(sha256
(base32 "0nbbs1inyrqds0ywn3ln5slv54v5zraq7lszkg8nsavv4kivhh9l"))
(patches (list (search-patch "nvi-assume-preserve-path.patch")))
(snippet
;; Create a wrapper for the configure script, make it executable.
'(let ((conf-wrap (open-output-file "configure")))
(display "#!/bin/sh" conf-wrap)
(newline conf-wrap)
(display
"../nvi-1.81.6/dist/configure --srcdir=../nvi-1.81.6/dist $@"
conf-wrap)
(newline conf-wrap)
(close-output-port conf-wrap)
(chmod "configure" #o0755)))))
(build-system gnu-build-system)
(arguments
`(#:out-of-source? #t))
(inputs
`(("bdb" ,bdb)
("ncurses" ,ncurses)))
(synopsis "The Berkeley Vi Editor")
(description
"Vi is the original screen based text editor for Unix systems. It is
considered the standard text editor, and is available on almost all Unix
systems. Nvi is intended as a \"bug-for-bug compatible\" clone of the original
BSD vi editor. As such, it doesn't have a lot of snazzy features as do some
of the other vi clones such as elvis and vim. However, if all you want is vi,
this is the one to get.")
(home-page "https://sites.google.com/a/bostic.com/keithbostic/vi")
(license bsd-3)))

4
gnu/packages/parallel.scm
View File

@ -27,7 +27,7 @@
(define-public parallel
(package
(name "parallel")
(version "20140722")
(version "20140822")
(source
(origin
(method url-fetch)
@ -35,7 +35,7 @@
version ".tar.bz2"))
(sha256
(base32
"165vf8hpl47z38aswsll1284l8xa9a8jwx3a3d2rzshm9yzbiq5n"))))
"1m3z77fnc2bfissq642p44xgw1jyp00wiwk1slhqj8bipicnl54a"))))
(build-system gnu-build-system)
(inputs `(("perl" ,perl)))
(home-page "http://www.gnu.org/software/parallel/")

30
gnu/packages/patches/nvi-assume-preserve-path.patch Normal file
View File

@ -0,0 +1,30 @@
Make configure assume nvi can store backups in /var/tmp.
--- a/dist/configure 2014-09-01 14:46:01.075778095 +0200
+++ b/dist/configure 2014-09-01 14:52:08.411790122 +0200
@@ -21319,23 +21319,8 @@
if test "${vi_cv_path_preserve+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
- dirlist="/var/preserve /var/tmp /usr/tmp"
- vi_cv_path_preserve=no
- for i in $dirlist; do
- if test -d $i/vi.recover; then
- vi_cv_path_preserve=$i/vi.recover
- break;
- fi
- done
- if test "$vi_cv_path_preserve" = no; then
- for i in $dirlist; do
- if test -d $i -a -w $i; then
- vi_cv_path_preserve=$i/vi.recover
- break;
- fi
- done
-
- fi
+# Assume /var/tmp
+ vi_cv_path_preserve=/var/tmp/vi.recover
fi
if test "$vi_cv_path_preserve" = no; then

52
gnu/packages/postgresql.scm Normal file
View File

@ -0,0 +1,52 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 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/>.
(define-module (gnu packages postgresql)
#:use-module ((guix licenses) #:select (x11-style))
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
#:use-module (gnu packages compression)
#:use-module (gnu packages readline))
(define-public postgresql
(package
(name "postgresql")
(version "9.3.5")
(source (origin
(method url-fetch)
(uri (string-append "http://ftp.postgresql.org/pub/source/v"
version "/postgresql-" version ".tar.gz"))
(sha256
(base32
"08kga00izykgvnx7hn995wc4zjqslspapaa8z63045p1ya14mr4g"))))
(build-system gnu-build-system)
(inputs
`(("readline" ,readline)
("zlib" ,zlib)))
(home-page "http://www.postgresql.org/")
(synopsis "Powerful object-relational database system")
(description
"PostgreSQL is a powerful object-relational database system. It is fully
ACID compliant, has full support for foreign keys, joins, views, triggers, and
stored procedures (in multiple languages). It includes most SQL:2008 data
types, including INTEGER, NUMERIC, BOOLEAN, CHAR, VARCHAR, DATE, INTERVAL, and
TIMESTAMP. It also supports storage of binary large objects, including
pictures, sounds, or video.")
(license (x11-style "file://COPYRIGHT"))))

870
gnu/packages/python.scm
View File

@ -22,8 +22,8 @@
(define-module (gnu packages python)
#:use-module ((guix licenses)
#:select (asl2.0 bsd-3 bsd-style cc0 expat x11 x11-style
gpl2 gpl2+ lgpl2.1+
#:select (asl2.0 bsd-3 bsd-2 bsd-style cc0 expat x11 x11-style
gpl2 gpl2+ gpl3+ lgpl2.0+ lgpl2.1+
psfl public-domain))
#:use-module ((guix licenses) #:select (zlib)
#:renamer (symbol-prefix-proc 'license:))
@ -939,6 +939,448 @@ In short, SCons is an easier, more reliable and faster way to build
software.")
(license x11)))
(define-public python-extras
(package
(name "python-extras")
(version "0.0.3")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/e/extras/extras-"
version ".tar.gz"))
(sha256
(base32
"1h7zx4dfyclalg0fqnfjijpn0f793a9mx8sy3b27gd31nr6dhq3s"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(arguments
;; error in setup.cfg: command 'test' has no such option 'buffer'
'(#:tests? #f))
(home-page "https://github.com/testing-cabal/extras")
(synopsis "Useful extensions to the Python standard library")
(description
"Extras is a set of extensions to the Python standard library.")
(license expat)))
(define-public python2-extras
(package-with-python2 python-extras))
(define-public python-mimeparse
(package
(name "python-mimeparse")
(version "0.1.4")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/p/python-mimeparse/python-mimeparse-"
version ".tar.gz"))
(sha256
(base32
"1hyxg09kaj02ri0rmwjqi86wk4nd1akvv7n0dx77azz76wga4s9w"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(arguments
'(#:tests? #f)) ; no setup.py test command
(home-page
"https://github.com/dbtsai/python-mimeparse")
(synopsis "Python library for parsing MIME types.")
(description
"Mimeparse provides basic functions for parsing MIME type names and
matching them against a list of media-ranges.")
(license expat)))
(define-public python2-mimeparse
(package-with-python2 python-mimeparse))
(define-public python-nose
(package
(name "python-nose")
(version "1.3.4")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/n/nose/nose-"
version ".tar.gz"))
(sha256
(base32
"00qymfgwg4iam4xi0w9bnv7lcb3fypq1hzfafzgs1rfmwaj67g3n"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(arguments
'(#:tests? #f)) ; FIXME: test suite fails
(home-page "http://readthedocs.org/docs/nose/")
(synopsis "Python testing library")
(description
"Nose extends the unittest library to make testing easier.")
(license lgpl2.0+)))
(define-public python2-nose
(package-with-python2 python-nose))
(define-public python-unittest2
(package
(name "python-unittest2")
(version "0.5.1")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/u/unittest2py3k/unittest2py3k-"
version ".tar.gz"))
(sha256
(base32
"00yl6lskygcrddx5zspkhr0ibgvpknl4678kkm6s626539grq93q"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "http://pypi.python.org/pypi/unittest2")
(synopsis "Python unit testing library")
(description
"Unittest2 is a replacement for the unittest module in the Python
standard library.")
(license psfl)))
(define-public python2-unittest2
(package (inherit python-unittest2)
(name "python2-unittest2")
(version "0.5.1")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/u/unittest2/unittest2-"
version ".tar.gz"))
(sha256
(base32
"0wbs4i4x3x7klr3v35ss6p9mcqz883i1xgcpkhvl7n2lyv6yhpda"))))
(inputs
`(("python2-setuptools" ,python-setuptools)))
(arguments
`(#:python ,python-2
#:tests? #f)))) ; no setup.py test command
(define-public python-py
(package
(name "python-py")
(version "1.4.23")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/p/py/py-"
version ".tar.gz"))
(sha256
(base32
"1jkhffpai419v5rickm2vz86p9bkg3b3kcm2k4bi5wfajhw2m3xs"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "http://pylib.readthedocs.org/")
(synopsis "Python library for parsing, I/O, instrospection, and logging")
(description
"Py is a Python library for file name parsing, .ini file parsing, I/O,
code introspection, and logging.")
(license expat)))
(define-public python2-py
(package-with-python2 python-py))
(define-public python-pytest
(package
(name "python-pytest")
(version "2.6.1")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/p/pytest/pytest-"
version ".tar.gz"))
(sha256
(base32
"0g2w4p0n42wvz8rq4k6gnzpkakgz3g8sfanxk8jrsra9675snkcr"))
(modules '((guix build utils)))
(snippet
;; One of the tests involves the /usr directory, so it fails.
'(substitute* "testing/test_argcomplete.py"
(("def test_remove_dir_prefix\\(self\\):")
"@pytest.mark.xfail\n def test_remove_dir_prefix(self):")))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-py" ,python-py)
("python-nose" ,python-nose)
("python-mock" ,python-mock)))
(home-page "http://pytest.org")
(synopsis "Python testing library")
(description
"Pytest is a testing tool that provides auto-discovery of test modules
and functions, detailed info on failing assert statements, modular fixtures,
and many external plugins.")
(license expat)))
(define-public python2-pytest
(package-with-python2 python-pytest))
(define-public python-scripttest
(package
(name "python-scripttest")
(version "1.3")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/s/scripttest/scripttest-"
version ".tar.gz"))
(sha256
(base32
"0f4w84k8ck82syys7yg9maz93mqzc8p5ymis941x034v44jzq74m"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-pytest" ,python-pytest)))
(home-page "http://pythonpaste.org/scripttest/")
(synopsis "Python library to test command-line scripts")
(description "Scripttest is a Python helper library for testing
interactive command-line applications. With it you can run a script in a
subprocess and see the output as well as any file modifications.")
(license expat)))
(define-public python2-scripttest
(package-with-python2 python-scripttest))
(define-public python-testtools
(package
(name "python-testtools")
(version "1.0.0")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/t/testtools/testtools-"
version ".tar.gz"))
(sha256
(base32
"1dyml28ykpl5jb9khdmcdvhy1cxqingys6qvj2k04fzlaj6z3bbx"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-mimeparse" ,python-mimeparse)
("python-extras" ,python-extras)))
(home-page "https://github.com/testing-cabal/testtools")
(synopsis
"Extensions to the Python standard library unit testing framework")
(description
"Testtools extends the Python standard library unit testing framework to
provide matchers, more debugging information, and cross-Python
compatibility.")
(license psfl)))
(define-public python2-testtools
(package-with-python2 python-testtools))
(define-public python-testscenarios
(package
(name "python-testscenarios")
(version "0.4")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/t/testscenarios/testscenarios-"
version ".tar.gz"))
(sha256
(base32
"1671jvrvqlmbnc42j7pc5y6vc37q44aiwrq0zic652pxyy2fxvjg"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-testtools" ,python-testtools)
("python-mimeparse" ,python-mimeparse)))
(home-page "https://launchpad.net/testscenarios")
(synopsis "Pyunit extension for dependency injection")
(description
"Testscenarios provides clean dependency injection for Python unittest
style tests.")
(license (list bsd-3 asl2.0)))) ; at the user's option
(define-public python2-testscenarios
(package-with-python2 python-testscenarios))
(define-public python-testresources
(package
(name "python-testresources")
(version "0.2.7")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/t/testresources/testresources-"
version ".tar.gz"))
(sha256
(base32
"0cbj3plbllyz42c4b5xxgwaa7mml54lakslrn4kkhinxhdri22md"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "https://launchpad.net/testresources")
(synopsis
"Pyunit extension for managing test resources")
(description
"Testresources is an extension to Python's unittest to allow declarative
use of resources by test cases.")
(license (list bsd-3 asl2.0)))) ; at the user's option
(define-public python2-testresources
(package-with-python2 python-testresources))
(define-public python-subunit
(package
(name "python-subunit")
(version "0.0.21")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/p/python-subunit/python-subunit-"
version ".tar.gz"))
(sha256
(base32
"1nkw9wfbvizmpajbj3in8ns07g7lwkiv8hip14jjlwk3cacls6jv"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-testtools" ,python-testtools)
("python-mimeparse" ,python-mimeparse)
("python-testscenarios" ,python-testscenarios)))
(home-page "http://launchpad.net/subunit")
(synopsis "Python implementation of the subunit protocol")
(description
"Python-subunit is a Python implementation of the subunit test streaming
protocol.")
(license (list bsd-3 asl2.0)))) ; at the user's option
(define-public python2-subunit
(package-with-python2 python-subunit))
(define-public python-fixtures
(package
(name "python-fixtures")
(version "0.3.16")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/f/fixtures/fixtures-"
version ".tar.gz"))
(sha256
(base32
"0x9r2gwilcig5g54k60bxzg96zabizq1855lrprlb4zckalp9asc"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(arguments
'(#:tests? #f)) ; no setup.py test command
(home-page "https://launchpad.net/python-fixtures")
(synopsis "Python test fixture library")
(description
"Fixtures provides a way to create reusable state, useful when writing
Python tests.")
(license (list bsd-3 asl2.0)))) ; at user's option
(define-public python2-fixtures
(package-with-python2 python-fixtures))
(define-public python-testrepository
(package
(name "python-testrepository")
(version "0.0.20")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/t/testrepository/testrepository-"
version ".tar.gz"))
(sha256
(base32
"1ssqb07c277010i6gzzkbdd46gd9mrj0bi0i8vn560n2k2y4j93m"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-testtools" ,python-testtools)
("python-subunit" ,python-subunit)
("python-fixtures" ,python-fixtures)
("python-mimeparse" ,python-mimeparse)))
(home-page "https://launchpad.net/testrepository")
(synopsis "Database for Python test results")
(description "Testrepository provides a database of test results which can
be used as part of a developer's workflow to check things such as what tests
have failed since the last commit or what tests are currently failing.")
(license (list bsd-3 asl2.0)))) ; at user's option
(define-public python2-testrepository
(package-with-python2 python-testrepository))
(define-public python-coverage
(package
(name "python-coverage")
(version "3.7.1")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/c/coverage/coverage-"
version ".tar.gz"))
(sha256
(base32
"0knlbq79g2ww6xzsyknj9rirrgrgc983dpa2d9nkdf31mb2a3bni"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "http://nedbatchelder.com/code/coverage")
(synopsis "Code coverage measurement for Python")
(description
"Coverage measures code coverage, typically during test execution. It
uses the code analysis tools and tracing hooks provided in the Python standard
library to determine which lines are executable, and which have been
executed.")
(license bsd-3)))
(define-public python2-coverage
(package-with-python2 python-coverage))
(define-public python-discover
(package
(name "python-discover")
(version "0.4.0")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/d/discover/discover-"
version ".tar.gz"))
(sha256
(base32
"0y8d0zwiqar51kxj8lzmkvwc3b8kazb04gk5zcb4nzg5k68zmhq5"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "http://pypi.python.org/pypi/discover/")
(synopsis
"Python test discovery for unittest")
(description
"Discover provides test discovery for unittest, a feature that has been
backported from Python 2.7 for Python 2.4+")
(license bsd-3)))
(define-public python2-discover
(package-with-python2 python-discover))
(define-public behave
(package
(name "behave")
@ -968,3 +1410,427 @@ technique that encourages collaboration between developers, QA and
non-technical or business participants in a software project. Behave uses
tests written in a natural language style, backed up by Python code.")
(license x11)))
(define-public python-exif-read
(package
(name "python-exif-read")
(version "1.4.2")
(source (origin
(method url-fetch)
(uri
(string-append
"https://pypi.python.org/packages/source/E/ExifRead/ExifRead-"
version ".tar.gz"))
(sha256
(base32
"17c627gcdmyc05hz4zk8qs4pjgw6rc68qzjzgz8gh1cmpsd7acf1"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(arguments `(#:tests? #f)) ; no tests
(home-page "https://github.com/ianare/exif-py")
(synopsis "Python library to extract EXIF data from image files")
(description
"ExifRead is a Python library to extract EXIF data from tiff and jpeg
files.")
(license bsd-3)))
(define-public python2-exif-read
(package-with-python2 python-exif-read))
(define-public python-pyld
(package
(name "python-pyld")
(version "0.6.0")
(source (origin
(method url-fetch)
(uri
(string-append
"https://pypi.python.org/packages/source/P/PyLD/PyLD-"
version ".tar.gz"))
(sha256
(base32
"1l9ymj85fsvayqplinzpk0kyiq6m74ps9xd3a9fhlxfn1rldf8x8"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(arguments `(#:tests? #f)) ; no tests
(home-page "http://github.com/digitalbazaar/pyld")
(synopsis "Python implementation of the JSON-LD specification")
(description
"PyLD is an implementation of the JSON-LD specification.")
(license bsd-3)))
(define-public python2-pyld
(package-with-python2 python-pyld))
(define-public python-certifi
(package
(name "python-certifi")
(version "14.05.14")
(source (origin
(method url-fetch)
(uri
(string-append
"https://pypi.python.org/packages/source/c/certifi/certifi-"
version ".tar.gz"))
(sha256
(base32
"0s8vxzfz6s4m6fvxc7z25k9j35w0rh6jkw3wwcd1az1mssncn6qy"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(arguments `(#:tests? #f)) ; no tests
(home-page "http://python-requests.org/")
(synopsis "Python CA certificate bundle")
(description
"Certifi is a Python library that contains a CA certificate bundle, which
is used by the Requests library to verify HTTPS requests.")
(license asl2.0)))
(define-public python2-certifi
(package-with-python2 python-certifi))
(define-public python2-requests
(package
(name "python2-requests")
(version "2.4.0")
(source (origin
(method url-fetch)
(uri
(string-append
"https://pypi.python.org/packages/source/r/requests/requests-"
version ".tar.gz"))
(sha256
(base32
"0gknlfx1wakrrm1zi8gi03x2lzj4dsns0vjw0nsmgqvkphyf01vh"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-certifi" ,python-certifi)))
(arguments `(#:tests? #f ; no tests
#:python ,python-2))
(home-page "http://python-requests.org/")
(synopsis "Python HTTP library")
(description
"Requests is a Python HTTP client library. It aims to be easier to use
than Python’s urllib2 library.")
(license asl2.0)))
(define-public python-jsonschema
(package
(name "python-jsonschema")
(version "2.4.0")
(source (origin
(method url-fetch)
(uri
(string-append
"https://pypi.python.org/packages/source/j/jsonschema/jsonschema-"
version ".tar.gz"))
(sha256
(base32
"1yik3031ziygvq66rj3mzfqdgxj29sg1bkfc46wsgi7lnbqs560j"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "http://github.com/Julian/jsonschema")
(synopsis "Implementation of JSON Schema for Python")
(description
"Jsonschema is an implementation of JSON Schema for Python.")
(license expat)))
(define-public python2-jsonschema
(package-with-python2 python-jsonschema))
(define-public python-unidecode
(package
(name "python-unidecode")
(version "0.04.16")
(source (origin
(method url-fetch)
(uri
(string-append
"https://pypi.python.org/packages/source/U/Unidecode/Unidecode-"
version ".tar.gz"))
(sha256
(base32
"0yv56vc49rvippyxgxvcyz7jklc07ky38rcspax7p00sgmriiljc"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "https://pypi.python.org/pypi/Unidecode")
(synopsis "ASCII transliterations of Unicode text")
(description
"Unidecode provides ASCII transliterations of Unicode text. Unidecode is
useful when integrating with legacy code that doesn't support Unicode, or for
ease of entry of non-Roman names on a US keyboard, or when constructing ASCII
machine identifiers from human-readable Unicode strings that should still be
somewhat intelligeble.")
(license gpl2+)))
(define-public python2-unidecode
(package-with-python2 python-unidecode))
(define-public python-pyjwt
(package
(name "python-pyjwt")
(version "0.2.1")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/P/PyJWT/PyJWT-"
version ".tar.gz"))
(sha256
(base32
"1ahqblfy2sj3xz34wsa48cn9rp0dspzq56p54i5znmws3b8gml6g"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(arguments
'(#:tests? #f)) ; test suite doesn't work
(home-page "http://github.com/progrium/pyjwt")
(synopsis "JSON Web Token implementation in Python")
(description
"PyJWT is a JSON Web Token implementation written in Python.")
(license expat)))
(define-public python2-pyjwt
(package-with-python2 python-pyjwt))
(define-public python-oauthlib
(package
(name "python-oauthlib")
(version "0.6.3")
(source (origin
(method url-fetch)
(uri
(string-append
"https://pypi.python.org/packages/source/o/oauthlib/oauthlib-"
version ".tar.gz"))
(sha256
(base32
"1yaj3j64la4arwsbhbfmpnickzh3jpg9nlpyg409v8pp24isn48a"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-pyjwt" ,python-pyjwt)
("python-pycrypto" ,python-pycrypto)
("python-nose" ,python-nose)
("python-mock" ,python-mock)))
(home-page "https://github.com/idan/oauthlib")
(synopsis "OAuth implementation for Python")
(description
"Oauthlib is a generic, spec-compliant, thorough implementation of the
OAuth request-signing logic.")
(license bsd-3)))
(define-public python2-oauthlib
(let ((base (package-with-python2 python-oauthlib)))
(package
(inherit base)
(name "python2-oauthlib")
(version "0.6.3")
(source (origin
(method url-fetch)
(uri
(string-append
"https://pypi.python.org/packages/source/o/oauthlib/oauthlib-"
version ".tar.gz"))
(sha256
(base32
"1yaj3j64la4arwsbhbfmpnickzh3jpg9nlpyg409v8pp24isn48a"))))
(inputs
(append (package-inputs base)
`(("python2-unittest2" ,python2-unittest2)))))))
(define-public python-itsdangerous
(package
(name "python-itsdangerous")
(version "0.24")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/i/itsdangerous/itsdangerous-"
version ".tar.gz"))
(sha256
(base32
"06856q6x675ly542ig0plbqcyab6ksfzijlyf1hzhgg3sgwgrcyb"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "http://github.com/mitsuhiko/itsdangerous")
(synopsis "Python library for passing data to/from untrusted environments")
(description
"Itsdangerous provides various helpers to pass trusted data to untrusted
environments and back.")
(license bsd-3)))
(define-public python2-itsdangerous
(package-with-python2 python-itsdangerous))
(define-public python-virtualenv
(package
(name "python-virtualenv")
(version "1.11.6")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/v/virtualenv/virtualenv-"
version ".tar.gz"))
(sha256
(base32
"1xq4prmg25n9cz5zcvbqx68lmc3kl39by582vd8pzs9f3qalqyiy"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-mock" ,python-mock)
("python-nose" ,python-nose)))
(home-page "https://virtualenv.pypa.io/")
(synopsis "Virtual Python environment builder")
(description
"Virtualenv is a tool to create isolated Python environments.")
(license expat)))
(define-public python2-virtualenv
(package-with-python2 python-virtualenv))
(define-public python-markupsafe
(package
(name "python-markupsafe")
(version "0.23")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/M/MarkupSafe/MarkupSafe-"
version ".tar.gz"))
(sha256
(base32
"1hvip33wva3fnmvfp9x5klqri7hpl1hkgqmjbss18nmrb7zimv54"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "http://github.com/mitsuhiko/markupsafe")
(synopsis "XML/HTML/XHTML markup safe string implementation for Python")
(description
"Markupsafe provides an XML/HTML/XHTML markup safe string implementation
for Python.")
(license bsd-3)))
(define-public python2-markupsafe
(package-with-python2 python-markupsafe))
(define-public python-jinja2
(package
(name "python-jinja2")
(version "2.7.3")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/J/Jinja2/Jinja2-"
version ".tar.gz"))
(sha256
(base32
"1nwg9yfqgy421lncnm63k1zf9xkd1klc0jm0fr4p3dad01fsq91f"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-markupsafe" ,python-markupsafe)))
(home-page "http://jinja.pocoo.org/")
(synopsis "Python template engine")
(description
"Jinja2 is a small but fast and easy to use stand-alone template engine
written in pure Python.")
(license bsd-3)))
(define-public python2-jinja2
(package-with-python2 python-jinja2))
(define-public python-docutils
(package
(name "python-docutils")
(version "0.12")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/d/docutils/docutils-"
version ".tar.gz"))
(sha256
(base32
"1ylnjnw1x4b2y7blr6x35ncdzn69k253kw4cdkv6asdb21w73ny7"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(arguments
'(#:tests? #f)) ; no setup.py test command
(home-page "http://docutils.sourceforge.net/")
(synopsis "Python Documentation Utilities")
(description
"Docutils is a modular system for processing documentation into useful
formats, such as HTML, XML, and LaTeX. For input Docutils supports
reStructuredText.")
;; Most of the source code is public domain, but some source files are
;; licensed under the PFSL, BSD 2-clause, and GPLv3+ licenses.
(license (list public-domain psfl bsd-2 gpl3+))))
(define-public python2-docutils
(package-with-python2 python-docutils))
(define-public python-pygments
(package
(name "python-pygments")
(version "1.6")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/P/Pygments/Pygments-"
version ".tar.gz"))
(sha256
(base32
"1h11r6ss8waih51vcksfvzghfxiav2f8svc0812fa5kmyz5d97kr"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)))
(home-page "http://pygments.org/")
(synopsis "Syntax highlighting")
(description
"Pygments is a syntax highlighting package written in Python.")
(license bsd-2)))
(define-public python2-pygments
(package-with-python2 python-pygments))
(define-public python-sphinx
(package
(name "python-sphinx")
(version "1.2.3")
(source
(origin
(method url-fetch)
(uri (string-append
"https://pypi.python.org/packages/source/S/Sphinx/Sphinx-"
version ".tar.gz"))
(sha256
(base32
"011xizm3jnmf4cvs5i6kgf6c5nn046h79i8j0vd0f27yw9j3p4wl"))))
(build-system python-build-system)
(inputs
`(("python-setuptools" ,python-setuptools)
("python-jinja2" ,python-jinja2)
("python-docutils" ,python-docutils)
("python-pygments" ,python-pygments)))
(home-page "http://sphinx-doc.org/")
(synopsis "Python documentation generator")
(description "Sphinx is a tool that makes it easy to create documentation
for Python projects or other documents consisting of multiple reStructuredText
sources.")
(license bsd-3)))
(define-public python2-sphinx
(package-with-python2 python-sphinx))

4
gnu/packages/telephony.scm
View File

@ -56,13 +56,13 @@ reimplementation.")
(define-public ucommon
(package
(name "ucommon")
(version "6.1.8")
(version "6.1.10")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/commoncpp/" name "-"
version ".tar.gz"))
(sha256 (base32
"1ibz5snb2gq0psw8z152qcbd1zaijpsksc3lrp6av60inyq3waws"))))
"14myyz4vdq1hzp39k835lk1c9pr4pkhzapsxv50qnh9w3v9mx8fp"))))
(build-system gnu-build-system)
(synopsis "(u)Common C++ framework for threaded applications")
(description "GNU Common C++ is an portable, optimized class framework for

2
gnu/services/base.scm
View File

@ -29,7 +29,7 @@
#:use-module ((gnu packages base)
#:select (canonical-package glibc))
#:use-module (gnu packages package-management)
#:use-module ((guix build linux-initrd)
#:use-module ((gnu build file-systems)
#:select (mount-flags->bit-mask))
#:use-module (guix gexp)
#:use-module (guix monads)

4
gnu/services/dmd.scm
View File

@ -35,7 +35,7 @@
(define modules
;; Extra modules visible to dmd.conf.
'((guix build syscalls)
(guix build linux-initrd)
(gnu build file-systems)
(guix build utils)))
(mlet %store-monad ((modules (imported-modules modules))
@ -50,7 +50,7 @@
(use-modules (ice-9 ftw)
(guix build syscalls)
(guix build utils)
((guix build linux-initrd)
((gnu build file-systems)
#:select (check-file-system canonicalize-device-spec)))
(register-services

9
gnu/system.scm
View File

@ -362,9 +362,10 @@ alias ll='ls -l'
stateful part of OS, including user accounts and groups, special directories,
etc."
(define %modules
'((guix build activation)
(guix build utils)
(guix build linux-initrd)))
'((gnu build activation)
(gnu build linux-boot)
(gnu build file-systems)
(guix build utils)))
(define (service-activations services)
;; Return the activation scripts for SERVICES.
@ -399,7 +400,7 @@ etc."
(set! %load-compiled-path
(cons #$compiled %load-compiled-path)))
(use-modules (guix build activation))
(use-modules (gnu build activation))
;; Populate /etc.
(activate-etc #$etc)

132
gnu/system/linux-initrd.scm
View File

@ -68,16 +68,22 @@ initrd."
;; General Linux overview in `Documentation/early-userspace/README' and
;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
(define (string->regexp str)
;; Return a regexp that matches STR exactly.
(string-append "^" (regexp-quote str) "$"))
(define graph-files
(unfold-right zero?
number->string
1-
(length to-copy)))
(mlet* %store-monad ((source (imported-modules modules))
(compiled (compiled-modules modules)))
(mlet %store-monad ((source (imported-modules modules))
(compiled (compiled-modules modules))
(module-dir (flat-linux-module-directory linux
linux-modules)))
(define builder
;; TODO: Move most of this code to (guix build linux-initrd).
;; TODO: Move most of this code to (gnu build linux-initrd).
#~(begin
(use-modules (guix build utils)
(use-modules (gnu build linux-initrd)
(guix build utils)
(guix build store-copy)
(ice-9 pretty-print)
(ice-9 popen)
(ice-9 match)
@ -87,9 +93,7 @@ initrd."
(rnrs bytevectors)
((system foreign) #:select (sizeof)))
(let ((cpio (string-append #$cpio "/bin/cpio"))
(gzip (string-append #$gzip "/bin/gzip"))
(modules #$source)
(let ((modules #$source)
(gos #$compiled)
(scm-dir (string-append "share/guile/" (effective-version)))
(go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a"
@ -101,6 +105,7 @@ initrd."
(effective-version))))
(mkdir #$output)
(mkdir "contents")
(with-directory-excursion "contents"
(copy-recursively #$guile ".")
(call-with-output-file "init"
@ -127,74 +132,58 @@ initrd."
#:output-file (string-append go-dir "/init.go"))
;; Copy Linux modules.
(let* ((linux #$linux)
(module-dir (and linux
(string-append linux "/lib/modules"))))
(mkdir "modules")
#$@(map (lambda (module)
#~(match (find-files module-dir
#$(string->regexp module))
((file)
(format #t "copying '~a'...~%" file)
(copy-file file (string-append "modules/"
#$module)))
(()
(error "module not found" #$module module-dir))
((_ ...)
(error "several modules by that name"
#$module module-dir))))
linux-modules))
(mkdir "modules")
(copy-recursively #$module-dir "modules")
(let ((store #$(string-append "." (%store-prefix)))
(to-copy '#$to-copy))
(unless (null? to-copy)
(mkdir-p store))
;; XXX: Should we do export-references-graph?
(for-each (lambda (input)
(let ((target
(string-append store "/"
(basename input))))
(copy-recursively input target)))
to-copy))
;; Populate the initrd's store.
(with-directory-excursion ".."
(populate-store '#$graph-files "contents"))
;; Reset the timestamps of all the files that will make it in the
;; initrd.
(for-each (cut utime <> 0 0 0 0)
(find-files "." ".*"))
(system* cpio "--version")
(let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
"-O" (string-append #$output "/initrd")
"-H" "newc" "--null")))
(define print0
(let ((len (string-length "./")))
(lambda (file)
(format pipe "~a\0" (string-drop file len)))))
;; Note: as per `ramfs-rootfs-initramfs.txt', always add
;; directory entries before the files that are inside of it: "The
;; Linux kernel cpio extractor won't create files in a directory
;; that doesn't exist, so the directory entries must go before
;; the files that go in those directories."
(file-system-fold (const #t)
(lambda (file stat result) ; leaf
(print0 file))
(lambda (dir stat result) ; down
(unless (string=? dir ".")
(print0 dir)))
(const #f) ; up
(const #f) ; skip
(const #f)
#f
".")
(and (zero? (close-pipe pipe))
(with-directory-excursion #$output
(and (zero? (system* gzip "--best" "initrd"))
(rename-file "initrd.gz" "initrd")))))))))
(write-cpio-archive (string-append #$output "/initrd") "."
#:cpio (string-append #$cpio "/bin/cpio")
#:gzip (string-append #$gzip "/bin/gzip"))))))
(gexp->derivation name builder
#:modules '((guix build utils)))))
#:modules '((guix build utils)
(guix build store-copy)
(gnu build linux-initrd))
#:references-graphs (zip graph-files to-copy))))
(define (flat-linux-module-directory linux modules)
"Return a flat directory containing the Linux kernel modules listed in
MODULES and taken from LINUX."
(define build-exp
#~(begin
(use-modules (ice-9 match) (ice-9 regex)
(guix build utils))
(define (string->regexp str)
;; Return a regexp that matches STR exactly.
(string-append "^" (regexp-quote str) "$"))
(define module-dir
(string-append #$linux "/lib/modules"))
(mkdir #$output)
(for-each (lambda (module)
(match (find-files module-dir (string->regexp module))
((file)
(format #t "copying '~a'...~%" file)
(copy-file file (string-append #$output "/" module)))
(()
(error "module not found" module module-dir))
((_ ...)
(error "several modules by that name"
module module-dir))))
'#$modules)))
(gexp->derivation "linux-modules" build-exp
#:modules '((guix build utils))))
(define (file-system->spec fs)
"Return a list corresponding to file-system FS that can be passed to the
@ -277,7 +266,7 @@ exception and backtrace!)."
(expression->initrd
#~(begin
(use-modules (guix build linux-initrd)
(use-modules (gnu build linux-boot)
(guix build utils)
(srfi srfi-26))
@ -293,7 +282,8 @@ exception and backtrace!)."
#:volatile-root? '#$volatile-root?))
#:name "base-initrd"
#:modules '((guix build utils)
(guix build linux-initrd))
(gnu build linux-boot)
(gnu build file-systems))
#:to-copy helper-packages
#:linux linux-libre
#:linux-modules linux-modules))

88
gnu/system/vm.scm
View File

@ -23,7 +23,7 @@
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix monads)
#:use-module ((guix build vm)
#:use-module ((gnu build vm)
#:select (qemu-command))
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
@ -112,10 +112,12 @@ input tuple. The output file name is when building for SYSTEM."
(qemu qemu-headless)
(env-vars '())
(modules
'((guix build vm)
(guix build install)
(guix build linux-initrd)
(guix build utils)))
'((gnu build vm)
(gnu build install)
(gnu build linux-boot)
(gnu build file-systems)
(guix build utils)
(guix build store-copy)))
(guile-for-build
(%guile-for-build))
@ -164,7 +166,7 @@ made available under the /xchg CIFS share."
;; Code that launches the VM that evaluates EXP.
#~(begin
(use-modules (guix build utils)
(guix build vm))
(gnu build vm))
(let ((inputs '#$(list qemu coreutils))
(linux (string-append #$linux "/bzImage"))
@ -217,48 +219,46 @@ INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
register INPUTS in the store database of the image so that Guix can be used in
the image."
(mlet %store-monad
((graph (sequence %store-monad (map input->name+output inputs))))
(expression->derivation-in-linux-vm
name
#~(begin
(use-modules (guix build vm)
(guix build utils))
(expression->derivation-in-linux-vm
name
#~(begin
(use-modules (gnu build vm)
(guix build utils))
(let ((inputs
'#$(append (list qemu parted grub e2fsprogs util-linux)
(map canonical-package
(list sed grep coreutils findutils gawk))
(if register-closures? (list guix) '())))
(let ((inputs
'#$(append (list qemu parted grub e2fsprogs util-linux)
(map canonical-package
(list sed grep coreutils findutils gawk))
(if register-closures? (list guix) '())))
;; This variable is unused but allows us to add INPUTS-TO-COPY
;; as inputs.
(to-register
'#$(map (match-lambda
((name thing) thing)
((name thing output) `(,thing ,output)))
inputs)))
;; This variable is unused but allows us to add INPUTS-TO-COPY
;; as inputs.
(to-register
'#$(map (match-lambda
((name thing) thing)
((name thing output) `(,thing ,output)))
inputs)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(let ((graphs '#$(match inputs
(((names . _) ...)
names))))
(initialize-hard-disk "/dev/vda"
#:system-directory #$os-derivation
#:grub.cfg #$grub-configuration
#:closures graphs
#:copy-closures? #$copy-inputs?
#:register-closures? #$register-closures?
#:disk-image-size #$disk-image-size
#:file-system-type #$file-system-type
#:file-system-label #$file-system-label)
(reboot))))
#:system system
#:make-disk-image? #t
#:disk-image-size disk-image-size
#:disk-image-format disk-image-format
#:references-graphs graph)))
(let ((graphs '#$(match inputs
(((names . _) ...)
names))))
(initialize-hard-disk "/dev/vda"
#:system-directory #$os-derivation
#:grub.cfg #$grub-configuration
#:closures graphs
#:copy-closures? #$copy-inputs?
#:register-closures? #$register-closures?
#:disk-image-size #$disk-image-size
#:file-system-type #$file-system-type
#:file-system-label #$file-system-label)
(reboot))))
#:system system
#:make-disk-image? #t
#:disk-image-size disk-image-size
#:disk-image-format disk-image-format
#:references-graphs inputs))
;;;

77
guix/build/pull.scm
View File

@ -21,6 +21,7 @@
#:use-module (system base compile)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@ -47,43 +48,70 @@ normally, and 1 if an exception is raised."
(pid
#t)))
(define* (report-build-progress total completed cont
#:optional (log-port (current-error-port)))
"Report that COMPLETED out of TOTAL files have been completed, and call
CONT."
(display #\cr log-port)
(format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
(* 100. (/ completed total)) total)
(force-output log-port)
(cont))
(define* (p-for-each proc lst
#:optional (max-processes (current-processor-count)))
#:optional (max-processes (current-processor-count))
#:key (progress report-build-progress))
"Invoke PROC for each element of LST in a separate process, using up to
MAX-PROCESSES processes in parallel. Raise an error if one of the processes
exit with non-zero."
MAX-PROCESSES processes in parallel. Call PROGRESS at each step, passing it
the continuation. Raise an error if one of the processes exit with non-zero."
(define total
(length lst))
(define (wait-for-one-process)
(match (waitpid WAIT_ANY)
((_ . status)
(unless (zero? (status:exit-val status))
(error "process failed" proc status)))))
(let loop ((lst lst)
(running 0))
(let loop ((lst lst)
(running 0)
(completed 0))
(match lst
(()
(or (zero? running)
(begin
(let ((running (- running 1))
(completed (+ completed 1)))
(wait-for-one-process)
(loop lst (- running 1)))))
(progress total completed
(lambda ()
(loop lst running completed))))))
((head . tail)
(if (< running max-processes)
(begin
(let ((running (+ 1 running)))
(call-with-process (cut proc head))
(loop tail (+ running 1)))
(begin
(progress total completed
(lambda ()
(loop tail running completed))))
(let ((running (- running 1))
(completed (+ completed 1)))
(wait-for-one-process)
(loop lst (- running 1))))))))
(progress total completed
(lambda ()
(loop lst running completed)))))))))
(define* (build-guix out tarball
#:key tar gzip gcrypt)
"Build and install Guix in directory OUT using source from TARBALL."
#:key tar gzip gcrypt
(debug-port (%make-void-port "w")))
"Build and install Guix in directory OUT using source from TARBALL. Write
any debugging output to DEBUG-PORT."
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
(setenv "PATH" (string-append tar "/bin:" gzip "/bin"))
(system* "tar" "xvf" tarball)
(format debug-port "extracting '~a'...~%" tarball)
(system* "tar" "xf" tarball)
(match (scandir "." (lambda (name)
(and (not (member name '("." "..")))
(file-is-directory? name))))
@ -92,11 +120,13 @@ exit with non-zero."
(x
(error "tarball did not produce a single source directory" x)))
(format #t "copying and compiling Guix to `~a'...~%" out)
(format #t "copying and compiling to '~a'...~%" out)
;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm.
(copy-recursively "guix" (string-append out "/guix"))
(copy-recursively "gnu" (string-append out "/gnu"))
(copy-recursively "guix" (string-append out "/guix")
#:log debug-port)
(copy-recursively "gnu" (string-append out "/gnu")
#:log debug-port)
(copy-file "guix.scm" (string-append out "/guix.scm"))
(copy-file "gnu.scm" (string-append out "/gnu.scm"))
@ -121,12 +151,12 @@ exit with non-zero."
(p-for-each (lambda (file)
(let ((go (string-append (string-drop-right file 4)
".go")))
(format (current-error-port)
"compiling '~a'...~%" file)
(compile-file file
#:output-file go
#:opts
%auto-compilation-options)))
(format debug-port "~%compiling '~a'...~%" file)
(parameterize ((current-warning-port debug-port))
(compile-file file
#:output-file go
#:opts
%auto-compilation-options))))
(filter (cut string-suffix? ".scm" <>)
@ -144,6 +174,7 @@ exit with non-zero."
(delete-file (string-append out "/guix/config.scm"))
(delete-file (string-append out "/guix/config.go"))
(newline)
#t)
;;; pull.scm ends here

69
guix/build/store-copy.scm Normal file
View File

@ -0,0 +1,69 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build store-copy)
#:use-module (guix build utils)
#:use-module (srfi srfi-1)
#:use-module (ice-9 rdelim)
#:export (read-reference-graph
populate-store))
;;; Commentary:
;;;
;;; This module provides the tools to copy store items and their dependencies
;;; to another store. It relies on the availability of "reference graph"
;;; files as produced by 'gexp->derivation' et al. with the
;;; #:references-graphs parameter.
;;;
;;; Code:
(define (read-reference-graph port)
"Return a list of store paths from the reference graph at PORT.
The data at PORT is the format produced by #:references-graphs."
(let loop ((line (read-line port))
(result '()))
(cond ((eof-object? line)
(delete-duplicates result))
((string-prefix? "/" line)
(loop (read-line port)
(cons line result)))
(else
(loop (read-line port)
result)))))
(define* (populate-store reference-graphs target)
"Populate the store under directory TARGET with the items specified in
REFERENCE-GRAPHS, a list of reference-graph files."
(define store
(string-append target (%store-directory)))
(define (things-to-copy)
;; Return the list of store files to copy to the image.
(define (graph-from-file file)
(call-with-input-file file read-reference-graph))
(delete-duplicates (append-map graph-from-file reference-graphs)))
(mkdir-p store)
(chmod store #o1775)
(for-each (lambda (thing)
(copy-recursively thing
(string-append target thing)))
(things-to-copy)))
;;; store-copy.scm ends here

67
guix/gexp.scm
View File

@ -109,6 +109,17 @@ the cross-compilation target triplet."
(return input)))
inputs))))
(define* (lower-reference-graphs graphs #:key system target)
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
#:reference-graphs argument, lower it such that each INPUT is replaced by the
corresponding derivation."
(match graphs
(((file-names . inputs) ...)
(mlet %store-monad ((inputs (lower-inputs inputs
#:system system
#:target target)))
(return (map cons file-names inputs))))))
(define* (gexp->derivation name exp
#:key
system (target 'current)
@ -127,10 +138,38 @@ names of Guile modules from the current search path to be copied in the store,
compiled, and made available in the load path during the execution of
EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
following forms:
(FILE-NAME PACKAGE)
(FILE-NAME PACKAGE OUTPUT)
(FILE-NAME DERIVATION)
(FILE-NAME DERIVATION OUTPUT)
(FILE-NAME STORE-ITEM)
The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
an input of the build process of EXP. In the build environment, each
FILE-NAME contains the reference graph of the corresponding item, in a simple
text format.
In that case, the reference graph of each store path is exported in
the build environment in the corresponding file, in a simple text format.
The other arguments are as for 'derivation'."
(define %modules modules)
(define outputs (gexp-outputs exp))
(define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
(map (match-lambda
((file-name (? derivation? drv))
(cons file-name (derivation->output-path drv)))
((file-name (? derivation? drv) sub-drv)
(cons file-name (derivation->output-path drv sub-drv)))
((file-name thing)
(cons file-name thing)))
graphs))
(mlet* %store-monad (;; The following binding is here to force
;; '%current-system' and '%current-target-system' to be
;; looked up at >>= time.
@ -162,6 +201,11 @@ The other arguments are as for 'derivation'."
#:system system
#:guile guile-for-build)
(return #f)))
(graphs (if references-graphs
(lower-reference-graphs references-graphs
#:system system
#:target target)
(return #f)))
(guile (if guile-for-build
(return guile-for-build)
(package->derivation (default-guile)
@ -182,9 +226,12 @@ The other arguments are as for 'derivation'."
(,builder)
,@(if modules
`((,modules) (,compiled) ,@inputs)
inputs))
inputs)
,@(match graphs
(((_ . inputs) ...) inputs)
(_ '())))
#:hash hash #:hash-algo hash-algo #:recursive? recursive?
#:references-graphs references-graphs
#:references-graphs (and=> graphs graphs-file-names)
#:local-build? local-build?)))
(define* (gexp-inputs exp #:optional (references gexp-references))
@ -449,14 +496,16 @@ its search path."
(format port
"#!~a/bin/guile --no-auto-compile~%!#~%"
(ungexp guile))
;; Write the 'eval-when' form so that it can be
;; compiled.
(write
'(set! %load-path
(cons (ungexp modules) %load-path))
port)
(write
'(set! %load-compiled-path
(cons (ungexp compiled)
%load-compiled-path))
'(eval-when (expand load eval)
(set! %load-path
(cons (ungexp modules) %load-path))
(set! %load-compiled-path
(cons (ungexp compiled)
%load-compiled-path)))
port)
(write '(ungexp exp) port)
(chmod port #o555)))))))

100
guix/profiles.scm
View File

@ -32,6 +32,7 @@
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:export (manifest make-manifest
@ -52,6 +53,7 @@
manifest-remove
manifest-add
manifest-lookup
manifest-installed?
manifest-matching-entries
@ -60,6 +62,7 @@
manifest-transaction-install
manifest-transaction-remove
manifest-perform-transaction
manifest-transaction-effects
manifest-show-transaction
profile-manifest
@ -235,11 +238,16 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
(manifest-entries manifest)
entries))))
(define (manifest-lookup manifest pattern)
"Return the first item of MANIFEST that matches PATTERN, or #f if there is
no match.."
(find (entry-predicate pattern)
(manifest-entries manifest)))
(define (manifest-installed? manifest pattern)
"Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
#f otherwise."
(->bool (find (entry-predicate pattern)
(manifest-entries manifest))))
(->bool (manifest-lookup manifest pattern)))
(define (manifest-matching-entries manifest patterns)
"Return all the entries of MANIFEST that match one of the PATTERNS."
@ -266,6 +274,39 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
(remove manifest-transaction-remove ; list of <manifest-pattern>
(default '())))
(define (manifest-transaction-effects manifest transaction)
"Compute the effect of applying TRANSACTION to MANIFEST. Return 3 values:
the list of packages that would be removed, installed, or upgraded when
applying TRANSACTION to MANIFEST. Upgrades are represented as pairs where the
head is the entry being upgraded and the tail is the entry that will replace
it."
(define (manifest-entry->pattern entry)
(manifest-pattern
(name (manifest-entry-name entry))
(output (manifest-entry-output entry))))
(let loop ((input (manifest-transaction-install transaction))
(install '())
(upgrade '()))
(match input
(()
(let ((remove (manifest-transaction-remove transaction)))
(values (manifest-matching-entries manifest remove)
(reverse install) (reverse upgrade))))
((entry rest ...)
;; Check whether installing ENTRY corresponds to the installation of a
;; new package or to an upgrade.
;; XXX: When the exact same output directory is installed, we're not
;; really upgrading anything. Add a check for that case.
(let* ((pattern (manifest-entry->pattern entry))
(previous (manifest-lookup manifest pattern)))
(loop rest
(if previous install (cons entry install))
(if previous
(alist-cons previous entry upgrade)
upgrade)))))))
(define (manifest-perform-transaction manifest transaction)
"Perform TRANSACTION on MANIFEST and return new manifest."
(let ((install (manifest-transaction-install transaction))
@ -273,35 +314,48 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
(manifest-add (manifest-remove manifest remove)
install)))
(define (right-arrow port)
"Return either a string containing the 'RIGHT ARROW' character, or an ASCII
replacement if PORT is not Unicode-capable."
(with-fluids ((%default-port-encoding (port-encoding port)))
(let ((arrow "→"))
(catch 'encoding-error
(lambda ()
(with-fluids ((%default-port-conversion-strategy 'error))
(with-output-to-string
(lambda ()
(display arrow)))))
(lambda (key . args)
"->")))))
(define* (manifest-show-transaction store manifest transaction
#:key dry-run?)
"Display what will/would be installed/removed from MANIFEST by TRANSACTION."
(define (package-strings name version output item)
(map (lambda (name version output item)
(format #f " ~a-~a\t~a\t~a" name version output
(format #f " ~a~:[:~a~;~*~]\t~a\t~a"
name
(equal? output "out") output version
(if (package? item)
(package-output store item output)
item)))
name version output item))
(let* ((remove (manifest-matching-entries
manifest (manifest-transaction-remove transaction)))
(install/upgrade (manifest-transaction-install transaction))
(install '())
(upgrade (append-map
(lambda (entry)
(let ((matching
(manifest-matching-entries
manifest
(list (manifest-pattern
(name (manifest-entry-name entry))
(output (manifest-entry-output entry)))))))
(when (null? matching)
(set! install (cons entry install)))
matching))
install/upgrade)))
(define → ;an arrow that can be represented on stderr
(right-arrow (current-error-port)))
(define (upgrade-string name old-version new-version output item)
(format #f " ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
name (equal? output "out") output
old-version → new-version
(if (package? item)
(package-output store item output)
item)))
(let-values (((remove install upgrade)
(manifest-transaction-effects manifest transaction)))
(match remove
((($ <manifest-entry> name version output item _) ..1)
((($ <manifest-entry> name version output item) ..1)
(let ((len (length name))
(remove (package-strings name version output item)))
(if dry-run?
@ -317,9 +371,11 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
remove))))
(_ #f))
(match upgrade
((($ <manifest-entry> name version output item _) ..1)
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
(upgrade (package-strings name version output item)))
(upgrade (map upgrade-string
name old-version new-version output item)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be upgraded:~%~{~a~%~}~%"

23
guix/scripts/build.scm
View File

@ -33,7 +33,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:autoload (gnu packages) (find-best-packages-by-name)
#:autoload (gnu packages) (specification->package)
#:autoload (guix download) (download-to-store)
#:export (%standard-build-options
set-build-options-from-command-line
@ -41,27 +41,6 @@
guix-build))
(define (specification->package spec)
"Return a package matching SPEC. SPEC may be a package name, or a package
name followed by a hyphen and a version number. If the version number is not
present, return the preferred newest version."
(let-values (((name version)
(package-name->name+version spec)))
(match (find-best-packages-by-name name version)
((p) ; one match
p)
((p x ...) ; several matches
(warning (_ "ambiguous package specification `~a'~%") spec)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
p)
(_ ; no matches
(if version
(leave (_ "~A: package not found for version ~a~%")
name version)
(leave (_ "~A: unknown package~%") name))))))
(define (register-root store paths root)
"Register ROOT as an indirect GC root for all of PATHS."
(let* ((root (string-append (canonicalize-path (dirname root))

213
guix/scripts/lint.scm Normal file
View File

@ -0,0 +1,213 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts lint)
#:use-module (guix base32)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (gnu packages)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-37)
#:export (guix-lint
check-inputs-should-be-native
check-patches
check-synopsis-style))
;;;
;;; Command-line options.
;;;
(define %default-options
;; Alist of default option values.
'())
(define (show-help)
(display (_ "Usage: guix lint [OPTION]... [PACKAGE]...
Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n"))
(display (_ "
-h, --help display this help and exit"))
(display (_ "
-l, --list-checkers display the list of available lint checkers"))
(display (_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(define %options
;; Specification of the command-line options.
;; TODO: add some options:
;; * --checkers=checker1,checker2...: only run the specified checkers
;; * --certainty=[low,medium,high]: only run checkers that have at least this
;; 'certainty'.
(list (option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\l "list-checkers") #f #f
(lambda args
(list-checkers-and-exit)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix lint")))))
;;;
;;; Helpers
;;;
(define* (emit-warning package message #:optional field)
;; Emit a warning about PACKAGE, printing the location of FIELD if it is
;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
;; provided MESSAGE.
(let ((loc (or (package-field-location package field)
(package-location package))))
(format (guix-warning-port) (_ "~a: ~a: ~a~%")
(location->string loc)
(package-full-name package)
message)))
;;;
;;; Checkers
;;;
(define-record-type* <lint-checker>
lint-checker make-lint-checker
lint-checker?
;; TODO: add a 'certainty' field that shows how confident we are in the
;; checker. Then allow users to only run checkers that have a certain
;; 'certainty' level.
(name lint-checker-name)
(description lint-checker-description)
(check lint-checker-check))
(define (list-checkers-and-exit)
;; Print information about all available checkers and exit.
(format #t (_ "Available checkers:~%"))
(for-each (lambda (checker)
(format #t "- ~a: ~a~%"
(lint-checker-name checker)
(lint-checker-description checker)))
%checkers)
(exit 0))
(define (check-inputs-should-be-native package)
;; Emit a warning if some inputs of PACKAGE are likely to belong to its
;; native inputs.
(let ((inputs (package-inputs package)))
(match inputs
(((labels packages . _) ...)
(when (member "pkg-config"
(map package-name (filter package? packages)))
(emit-warning package
"pkg-config should probably be a native input"
'inputs))))))
(define (check-synopsis-style package)
;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
(define (check-final-period synopsis)
;; Synopsis should not end with a period, except for some special cases.
(if (and (string=? (string-take-right synopsis 1) ".")
(not (string=? (string-take-right synopsis 4) "etc.")))
(emit-warning package
"no period allowed at the end of the synopsis"
'synopsis)))
(define (check-start-article synopsis)
(if (or (string=? (string-take synopsis 2) "A ")
(string=? (string-take synopsis 3) "An "))
(emit-warning package
"no article allowed at the beginning of the synopsis"
'synopsis)))
(let ((synopsis (package-synopsis package)))
(if (string? synopsis)
(begin
(check-final-period synopsis)
(check-start-article synopsis)))))
(define (check-patches package)
;; Emit a warning if the patches requires by PACKAGE are badly named.
(let ((patches (and=> (package-source package) origin-patches))
(name (package-name package))
(full-name (package-full-name package)))
(if (and patches
(any (lambda (patch)
(let ((filename (basename patch)))
(not (or (eq? (string-contains filename name) 0)
(eq? (string-contains filename full-name) 0)))))
patches))
(emit-warning package
"file names of patches should start with the package name"
'patches))))
(define %checkers
(list
(lint-checker
(name "inputs-should-be-native")
(description "Identify inputs that should be native inputs")
(check check-inputs-should-be-native))
(lint-checker
(name "patch-filenames")
(description "Validate filenames of patches")
(check check-patches))
(lint-checker
(name "synopsis")
(description "Validate package synopsis")
(check check-synopsis-style))))
(define (run-checkers package)
;; Run all the checkers on PACKAGE.
(for-each (lambda (checker)
((lint-checker-check checker) package))
%checkers))
;;;
;;; Entry Point
;;;
(define (guix-lint . args)
(define (parse-options)
;; Return the alist of option values.
(args-fold* args %options
(lambda (opt name arg result)
(leave (_ "~A: unrecognized option~%") name))
(lambda (arg result)
(alist-cons 'argument arg result))
%default-options))
(let* ((opts (parse-options))
(args (filter-map (match-lambda
(('argument . value)
value)
(_ #f))
(reverse opts))))
(if (null? args)
(fold-packages (lambda (p r) (run-checkers p)) '())
(for-each
(lambda (spec)
(run-checkers spec))
(map specification->package args)))))

20
guix/scripts/offload.scm
View File

@ -181,7 +181,8 @@ determined."
#:key (error-port (current-error-port)) (quote? #t))
"Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been
set up. When QUOTE? is true, perform shell-quotation of all the elements of
COMMAND."
COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could
not be started."
(define (shell-quote str)
;; Sort-of shell-quote STR so it can be passed as an argument to the
;; shell.
@ -315,8 +316,17 @@ hook."
(let ((root-directory (string-append %state-directory
"/gcroots/tmp")))
(false-if-exception (mkdir root-directory))
(symlink ,file
(string-append root-directory "/" ,%gc-root-file)))))
(catch 'system-error
(lambda ()
(symlink ,file
(string-append root-directory "/" ,%gc-root-file)))
(lambda args
;; If FILE already exists, we can assume that either it's a stale
;; reference (which is fine), or another process is already
;; building the derivation represented by FILE (which is fine
;; too.) Thus, do nothing in that case.
(unless (= EEXIST (system-error-errno args))
(apply throw args)))))))
(let ((pipe (remote-pipe machine OPEN_READ
`("guile" "-c" ,(object->string script)))))
@ -535,7 +545,7 @@ allowed on MACHINE."
(line (read-line pipe)))
(close-pipe pipe)
(if (eof-object? line)
1.
+inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
(match (string-tokenize line)
((one five fifteen . _)
(let* ((raw (string->number five))
@ -546,7 +556,7 @@ allowed on MACHINE."
(build-machine-name machine) raw normalized)
normalized))
(_
1.)))))
+inf.0))))) ;something's fishy about MACHINE, so avoid it
(define (machine-less-loaded? m1 m2)
"Return #t if the load on M1 is lower than that on M2."

8
guix/scripts/package.scm
View File

@ -305,10 +305,12 @@ current settings and report only settings not already effective."
;; Use 'find-best-packages-by-name' and not 'find-packages-by-name';
;; the former traverses the module tree only once and then allows for
;; efficient access via a vhash.
(match (or (find-best-packages-by-name name version)
(find-best-packages-by-name name #f))
(match (find-best-packages-by-name name version)
((p _ ...) p)
(_ #f)))))
(_
(match (find-best-packages-by-name name #f)
((p _ ...) p)
(_ #f)))))))
(define search-path-definition
(match-lambda

19
guix/scripts/pull.scm
View File

@ -38,15 +38,21 @@
"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
)
(define (unpack store tarball)
(define* (unpack store tarball #:key verbose?)
"Return a derivation that unpacks TARBALL into STORE and compiles Scheme
files."
(define builder
'(begin
`(begin
(use-modules (guix build pull))
(build-guix (assoc-ref %outputs "out")
(assoc-ref %build-inputs "tarball")
;; XXX: This is not perfect, enabling VERBOSE? means
;; building a different derivation.
#:debug-port (if ',verbose?
(current-error-port)
(%make-void-port "w"))
#:tar (assoc-ref %build-inputs "tar")
#:gzip (assoc-ref %build-inputs "gzip")
#:gcrypt (assoc-ref %build-inputs "gcrypt"))))
@ -129,13 +135,10 @@ Download and deploy the latest version of Guix.\n"))
(package-derivation store
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
(canonical-package guile-2.0))))
(current-build-output-port
(if (assoc-ref opts 'verbose?)
(current-error-port)
(%make-void-port "w"))))
(canonical-package guile-2.0)))))
(let* ((config-dir (config-directory))
(source (unpack store tarball))
(source (unpack store tarball
#:verbose? (assoc-ref opts 'verbose?)))
(source-dir (derivation->output-path source)))
(if (show-what-to-build store (list source))
(if (build-derivations store (list source))

2
guix/scripts/system.scm
View File

@ -28,7 +28,7 @@
#:use-module (guix profiles)
#:use-module (guix scripts build)
#:use-module (guix build utils)
#:use-module (guix build install)
#:use-module (gnu build install)
#:use-module (gnu system)
#:use-module (gnu system vm)
#:use-module (gnu system grub)

19
nix/nix-daemon/guix-daemon.cc
View File

@ -62,7 +62,7 @@ builds derivations on behalf of its clients.";
#define GUIX_OPT_CACHE_FAILURES 4
#define GUIX_OPT_LOSE_LOGS 5
#define GUIX_OPT_DISABLE_LOG_COMPRESSION 6
#define GUIX_OPT_DISABLE_STORE_OPTIMIZATION 7
#define GUIX_OPT_DISABLE_DEDUPLICATION 7
#define GUIX_OPT_IMPERSONATE_LINUX_26 8
#define GUIX_OPT_DEBUG 9
#define GUIX_OPT_CHROOT_DIR 10
@ -106,8 +106,14 @@ static const struct argp_option options[] =
"Do not keep build logs" },
{ "disable-log-compression", GUIX_OPT_DISABLE_LOG_COMPRESSION, 0, 0,
"Disable compression of the build logs" },
{ "disable-store-optimization", GUIX_OPT_DISABLE_STORE_OPTIMIZATION, 0, 0,
/* '--disable-deduplication' was known as '--disable-store-optimization'
up to Guix 0.7 included, so keep the alias around. */
{ "disable-deduplication", GUIX_OPT_DISABLE_DEDUPLICATION, 0, 0,
"Disable automatic file \"deduplication\" in the store" },
{ "disable-store-optimization", GUIX_OPT_DISABLE_DEDUPLICATION, 0,
OPTION_ALIAS | OPTION_HIDDEN, NULL },
{ "impersonate-linux-2.6", GUIX_OPT_IMPERSONATE_LINUX_26, 0, 0,
"Impersonate Linux 2.6"
#ifndef HAVE_SYS_PERSONALITY_H
@ -163,7 +169,7 @@ parse_opt (int key, char *arg, struct argp_state *state)
case GUIX_OPT_BUILD_USERS_GROUP:
settings.buildUsersGroup = arg;
break;
case GUIX_OPT_DISABLE_STORE_OPTIMIZATION:
case GUIX_OPT_DISABLE_DEDUPLICATION:
settings.autoOptimiseStore = false;
break;
case GUIX_OPT_CACHE_FAILURES:
@ -249,6 +255,9 @@ main (int argc, char *argv[])
settings.useChroot = false;
#endif
/* Turn automatic deduplication on by default. */
settings.autoOptimiseStore = true;
argvSaved = argv;
try
@ -325,6 +334,10 @@ main (int argc, char *argv[])
}
#endif
printMsg (lvlDebug,
format ("automatic deduplication set to %1%")
% settings.autoOptimiseStore);
printMsg (lvlDebug,
format ("listening on `%1%'") % settings.nixDaemonSocketFile);

13
nix/sync-with-upstream
View File

@ -1,6 +1,6 @@
#!/bin/sh
# GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@ -65,7 +65,16 @@ done
rm -fv "$top_srcdir/nix/libstore/schema.sql.hh"
cp -v "$top_srcdir/nix-upstream/COPYING" "$top_srcdir/nix"
cp -v "$top_srcdir/nix-upstream/AUTHORS" "$top_srcdir/nix"
# Generate an 'AUTHORS' file since upstream Nix no longer has one.
cat > "$top_srcdir/nix/AUTHORS" <<EOF
Most of the code is this directory was written by the following people for
the Nix project (http://nixos.org/nix). Thank you!
EOF
( cd "$top_srcdir/nix-upstream" ; git shortlog --summary ) \
| sed -'es/^ *[0-9]\+\(.*\)/ \1/g' \
>> "$top_srcdir/nix/AUTHORS"
# Substitutions.
sed -i "$top_srcdir/nix/libstore/gc.cc" \

3
po/guix/Makevars
View File

@ -10,7 +10,8 @@ top_builddir = ../..
XGETTEXT_OPTIONS = \
--language=Scheme --from-code=UTF-8 \
--keyword=_ --keyword=N_ \
--keyword=message
--keyword=message \
--keyword=description
COPYRIGHT_HOLDER = Ludovic Courtès

1
po/guix/POTFILES.in
View File

@ -10,6 +10,7 @@ guix/scripts/pull.scm
guix/scripts/substitute-binary.scm
guix/scripts/authenticate.scm
guix/scripts/system.scm
guix/scripts/lint.scm
guix/gnu-maintenance.scm
guix/ui.scm
guix/http-client.scm

22
tests/derivations.scm
View File

@ -151,6 +151,28 @@
;; the contents.
(valid-path? %store (derivation->output-path drv)))))
(test-assert "identical files are deduplicated"
(let* ((build1 (add-text-to-store %store "one.sh"
"echo hello, world > \"$out\"\n"
'()))
(build2 (add-text-to-store %store "two.sh"
"# Hey!\necho hello, world > \"$out\"\n"
'()))
(drv1 (derivation %store "foo"
%bash `(,build1)
#:inputs `((,%bash) (,build1))))
(drv2 (derivation %store "bar"
%bash `(,build2)
#:inputs `((,%bash) (,build2)))))
(and (build-derivations %store (list drv1 drv2))
(let ((file1 (derivation->output-path drv1))
(file2 (derivation->output-path drv2)))
(and (valid-path? %store file1) (valid-path? %store file2)
(string=? (call-with-input-file file1 get-string-all)
"hello, world\n")
(= (stat:ino (lstat file1))
(stat:ino (lstat file2))))))))
(test-assert "fixed-output-derivation?"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo -n hello > $out" '()))

72
tests/gexp.scm
View File

@ -324,6 +324,78 @@
(return (string=? (derivation-file-name drv)
(derivation-file-name xdrv)))))
(test-assertm "gexp->derivation, store copy"
(let ((build-one #~(call-with-output-file #$output
(lambda (port)
(display "This is the one." port))))
(build-two (lambda (one)
#~(begin
(mkdir #$output)
(symlink #$one (string-append #$output "/one"))
(call-with-output-file (string-append #$output "/two")
(lambda (port)
(display "This is the second one." port))))))
(build-drv #~(begin
(use-modules (guix build store-copy))
(mkdir #$output)
(populate-store '("graph") #$output))))
(mlet* %store-monad ((one (gexp->derivation "one" build-one))
(two (gexp->derivation "two" (build-two one)))
(drv (gexp->derivation "store-copy" build-drv
#:references-graphs
`(("graph" ,two))
#:modules
'((guix build store-copy)
(guix build utils))))
(ok? (built-derivations (list drv)))
(out -> (derivation->output-path drv)))
(let ((one (derivation->output-path one))
(two (derivation->output-path two)))
(return (and ok?
(file-exists? (string-append out "/" one))
(file-exists? (string-append out "/" two))
(file-exists? (string-append out "/" two "/two"))
(string=? (readlink (string-append out "/" two "/one"))
one)))))))
(test-assertm "gexp->derivation #:references-graphs"
(mlet* %store-monad
((one (text-file "one" "hello, world"))
(two (gexp->derivation "two"
#~(symlink #$one #$output:chbouib)))
(drv (gexp->derivation "ref-graphs"
#~(begin
(use-modules (guix build store-copy))
(with-output-to-file #$output
(lambda ()
(write (call-with-input-file "guile"
read-reference-graph))))
(with-output-to-file #$output:one
(lambda ()
(write (call-with-input-file "one"
read-reference-graph))))
(with-output-to-file #$output:two
(lambda ()
(write (call-with-input-file "two"
read-reference-graph)))))
#:references-graphs `(("one" ,one)
("two" ,two "chbouib")
("guile" ,%bootstrap-guile))
#:modules '((guix build store-copy)
(guix build utils))))
(ok? (built-derivations (list drv)))
(guile-drv (package->derivation %bootstrap-guile))
(g-one -> (derivation->output-path drv "one"))
(g-two -> (derivation->output-path drv "two"))
(g-guile -> (derivation->output-path drv)))
(return (and ok?
(equal? (call-with-input-file g-one read) (list one))
(equal? (call-with-input-file g-two read)
(list one (derivation->output-path two "chbouib")))
(equal? (call-with-input-file g-guile read)
(list (derivation->output-path guile-drv)))))))
(define shebang
(string-append "#!" (derivation->output-path (%guile-for-build))
"/bin/guile --no-auto-compile"))

110
tests/lint.scm Normal file
View File

@ -0,0 +1,110 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-packages)
#:use-module (guix build download)
#:use-module (guix build-system gnu)
#:use-module (guix packages)
#:use-module (guix scripts lint)
#:use-module (guix ui)
#:use-module (gnu packages)
#:use-module (gnu packages pkg-config)
#:use-module (srfi srfi-64))
;; Test the linter.
(test-begin "lint")
(define-syntax-rule (dummy-package name* extra-fields ...)
(package extra-fields ... (name name*) (version "0") (source #f)
(build-system gnu-build-system)
(synopsis #f) (description #f)
(home-page #f) (license #f) ))
(define (call-with-warnings thunk)
(let ((port (open-output-string)))
(parameterize ((guix-warning-port port))
(thunk))
(get-output-string port)))
(test-assert "synopsis: ends with a period"
(->bool
(string-contains (call-with-warnings
(lambda ()
(let ((pkg (dummy-package "x"
(synopsis "Bad synopsis."))))
(check-synopsis-style pkg))))
"no period allowed at the end of the synopsis")))
(test-assert "synopsis: ends with 'etc.'"
(->bool
(string-null? (call-with-warnings
(lambda ()
(let ((pkg (dummy-package "x"
(synopsis "Foo, bar, etc."))))
(check-synopsis-style pkg)))))))
(test-assert "synopsis: starts with 'A'"
(->bool
(string-contains (call-with-warnings
(lambda ()
(let ((pkg (dummy-package "x"
(synopsis "A bad synopŝis"))))
(check-synopsis-style pkg))))
"no article allowed at the beginning of the synopsis")))
(test-assert "synopsis: starts with 'An'"
(->bool
(string-contains (call-with-warnings
(lambda ()
(let ((pkg (dummy-package "x"
(synopsis "An awful synopsis"))))
(check-synopsis-style pkg))))
"no article allowed at the beginning of the synopsis")))
(test-assert "inputs: pkg-config is probably a native input"
(->bool
(string-contains
(call-with-warnings
(lambda ()
(let ((pkg (dummy-package "x"
(inputs `(("pkg-config" ,pkg-config))))))
(check-inputs-should-be-native pkg))))
"pkg-config should probably be a native input")))
(test-assert "patches: file names"
(->bool
(string-contains
(call-with-warnings
(lambda ()
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "someurl")
(sha256 "somesha")
(patches (list "/path/to/y.patch")))))))
(check-patches pkg))))
"file names of patches should start with the package name")))
(test-end "lint")
(exit (= (test-runner-fail-count (test-runner-current)) 0))

37
tests/profiles.scm
View File

@ -26,6 +26,8 @@
#:use-module (guix derivations)
#:use-module (gnu packages bootstrap)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-64))
;; Test the (guix profiles) module.
@ -53,6 +55,13 @@
(manifest-entry (inherit guile-2.0.9)
(output "debug")))
(define glibc
(manifest-entry
(name "glibc")
(version "2.19")
(item "/gnu/store/...")
(output "out")))
(test-begin "profiles")
@ -136,6 +145,34 @@
(equal? m1 m2)
(null? (manifest-entries m3)))))
(test-assert "manifest-transaction-effects"
(let* ((m0 (manifest (list guile-1.8.8)))
(t (manifest-transaction
(install (list guile-2.0.9 glibc))
(remove (list (manifest-pattern (name "coreutils")))))))
(let-values (((remove install upgrade)
(manifest-transaction-effects m0 t)))
(and (null? remove)
(equal? (list glibc) install)
(equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
(test-assert "manifest-show-transaction"
(let* ((m (manifest (list guile-1.8.8)))
(t (manifest-transaction (install (list guile-2.0.9)))))
(let-values (((remove install upgrade)
(manifest-transaction-effects m t)))
(with-store store
(and (string-match "guile\t1.8.8 → 2.0.9"
(with-fluids ((%default-port-encoding "UTF-8"))
(with-error-to-string
(lambda ()
(manifest-show-transaction store m t)))))
(string-match "guile\t1.8.8 -> 2.0.9"
(with-fluids ((%default-port-encoding "ISO-8859-1"))
(with-error-to-string
(lambda ()
(manifest-show-transaction store m t))))))))))
(test-assert "profile-derivation"
(run-with-store %store
(mlet* %store-monad