Merge branch 'master' into core-updates
Mark H Weaver
commit
e759c0a38c
|
|
@ -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
7
HACKING
|
|
@ -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
13
Makefile.am
|
|
@ -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
16
README
|
|
@ -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
1
THANKS
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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)\")))"
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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")
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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)))))))))
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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."
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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+)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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+)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -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/")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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"))))
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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~%~}~%"
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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" \
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" '()))
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue