diff options
63 files changed, 5979 insertions, 569 deletions
diff --git a/.gitignore b/.gitignore index dacd234c9b..a424a397c4 100644 --- a/.gitignore +++ b/.gitignore @@ -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 @@ -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. diff --git a/Makefile.am b/Makefile.am index fff5958355..1f2c4db80d 100644 --- a/Makefile.am +++ b/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 @@ -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 @@ -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> diff --git a/config-daemon.ac b/config-daemon.ac index a13525a7f5..072fb84b46 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -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. diff --git a/configure.ac b/configure.ac index 71b3ddacaa..698dd85784 100644 --- a/configure.ac +++ b/configure.ac @@ -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 diff --git a/doc/emacs.texi b/doc/emacs.texi new file mode 100644 index 0000000000..55feb1bf9f --- /dev/null +++ b/doc/emacs.texi @@ -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 diff --git a/doc/guix.texi b/doc/guix.texi index b6cd57acc2..e0251f5ffd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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. diff --git a/emacs.am b/emacs.am new file mode 100644 index 0000000000..86ae3a2c9f --- /dev/null +++ b/emacs.am @@ -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)\")))" diff --git a/emacs/guix-backend.el b/emacs/guix-backend.el new file mode 100644 index 0000000000..46d0f06778 --- /dev/null +++ b/emacs/guix-backend.el @@ -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 diff --git a/emacs/guix-base.el b/emacs/guix-base.el new file mode 100644 index 0000000000..563df496cd --- /dev/null +++ b/emacs/guix-base.el @@ -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 diff --git a/emacs/guix-helper.scm.in b/emacs/guix-helper.scm.in new file mode 100644 index 0000000000..554d55119f --- /dev/null +++ b/emacs/guix-helper.scm.in @@ -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") + diff --git a/emacs/guix-history.el b/emacs/guix-history.el new file mode 100644 index 0000000000..5d301a689e --- /dev/null +++ b/emacs/guix-history.el @@ -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 diff --git a/emacs/guix-info.el b/emacs/guix-info.el new file mode 100644 index 0000000000..687a15eefa --- /dev/null +++ b/emacs/guix-info.el @@ -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 diff --git a/emacs/guix-init.el.in b/emacs/guix-init.el.in new file mode 100644 index 0000000000..4e62728187 --- /dev/null +++ b/emacs/guix-init.el.in @@ -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) diff --git a/emacs/guix-list.el b/emacs/guix-list.el new file mode 100644 index 0000000000..08fb3cba5c --- /dev/null +++ b/emacs/guix-list.el @@ -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 diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm new file mode 100644 index 0000000000..1383d08830 --- /dev/null +++ b/emacs/guix-main.scm @@ -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))))))))) + diff --git a/emacs/guix-utils.el b/emacs/guix-utils.el new file mode 100644 index 0000000000..c1fe1a3a38 --- /dev/null +++ b/emacs/guix-utils.el @@ -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 diff --git a/emacs/guix.el b/emacs/guix.el new file mode 100644 index 0000000000..7336f6732e --- /dev/null +++ b/emacs/guix.el @@ -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 diff --git a/gnu-system.am b/gnu-system.am index 6213763326..510a217b98 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -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 \ diff --git a/guix/build/activation.scm b/gnu/build/activation.scm index b04b017881..362669cbf9 100644 --- a/guix/build/activation.scm +++ b/gnu/build/activation.scm @@ -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) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm new file mode 100644 index 0000000000..5c04771e19 --- /dev/null +++ b/gnu/build/file-systems.scm @@ -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 diff --git a/guix/build/install.scm b/gnu/build/install.scm index 5bafe905de..e16896f8b8 100644 --- a/guix/build/install.scm +++ b/gnu/build/install.scm @@ -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 diff --git a/guix/build/linux-initrd.scm b/gnu/build/linux-boot.scm index d37da9a6ff..21ee58ad50 100644 --- a/guix/build/linux-initrd.scm +++ b/gnu/build/linux-boot.scm @@ -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." diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm new file mode 100644 index 0000000000..bf60137e8f --- /dev/null +++ b/gnu/build/linux-initrd.scm @@ -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 diff --git a/guix/build/vm.scm b/gnu/build/vm.scm index 11e05f70be..27ccd047b7 100644 --- a/guix/build/vm.scm +++ b/gnu/build/vm.scm @@ -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 diff --git a/gnu/packages.scm b/gnu/packages.scm index 14ad75561c..26d87c6b16 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -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)))))) diff --git a/gnu/packages/avahi.scm b/gnu/packages/avahi.scm index d3a92844c2..3f2fdffc28 100644 --- a/gnu/packages/avahi.scm +++ b/gnu/packages/avahi.scm @@ -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+))) diff --git a/gnu/packages/commencement.scm b/gnu/packages/commencement.scm index a07ed85946..79c22a5974 100644 --- a/gnu/packages/commencement.scm +++ b/gnu/packages/commencement.scm @@ -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 diff --git a/gnu/packages/datamash.scm b/gnu/packages/datamash.scm index 543cd038d3..ccf3729b0b 100644 --- a/gnu/packages/datamash.scm +++ b/gnu/packages/datamash.scm @@ -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+))) diff --git a/gnu/packages/gnutls.scm b/gnu/packages/gnutls.scm index 9b91a311a3..89fc86d6ad 100644 --- a/gnu/packages/gnutls.scm +++ b/gnu/packages/gnutls.scm @@ -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) diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index 02a0ae36b5..442f80103a 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -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 diff --git a/gnu/packages/man.scm b/gnu/packages/man.scm index 2e319a897e..1dbc4c96d5 100644 --- a/gnu/packages/man.scm +++ b/gnu/packages/man.scm @@ -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)) diff --git a/gnu/packages/nvi.scm b/gnu/packages/nvi.scm new file mode 100644 index 0000000000..3037e5bafc --- /dev/null +++ b/gnu/packages/nvi.scm @@ -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))) diff --git a/gnu/packages/parallel.scm b/gnu/packages/parallel.scm index a4755e043d..92f15adbc4 100644 --- a/gnu/packages/parallel.scm +++ b/gnu/packages/parallel.scm @@ -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/") diff --git a/gnu/packages/patches/nvi-assume-preserve-path.patch b/gnu/packages/patches/nvi-assume-preserve-path.patch new file mode 100644 index 0000000000..18a8f68cca --- /dev/null +++ b/gnu/packages/patches/nvi-assume-preserve-path.patch @@ -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 diff --git a/gnu/packages/postgresql.scm b/gnu/packages/postgresql.scm new file mode 100644 index 0000000000..d6b505f6a2 --- /dev/null +++ b/gnu/packages/postgresql.scm @@ -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")))) diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 641a5dfc67..81b6c956a9 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -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)) diff --git a/gnu/packages/telephony.scm b/gnu/packages/telephony.scm index 363058dd54..b127d70976 100644 --- a/gnu/packages/telephony.scm +++ b/gnu/packages/telephony.scm @@ -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 diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 578d4cba71..b5b49d1a01 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -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) diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index dfda2708f5..59c2373779 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -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 diff --git a/gnu/system.scm b/gnu/system.scm index 2469ade1f3..ea7fdf1cb7 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -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) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index e48b399a9d..627d17bac2 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -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) "$")) - - (mlet* %store-monad ((source (imported-modules modules)) - (compiled (compiled-modules modules))) + (define graph-files + (unfold-right zero? + number->string + 1- + (length to-copy))) + + (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)) - - (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)) + (mkdir "modules") + (copy-recursively #$module-dir "modules") + + ;; 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)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 42fc23ee8f..205bf2cb19 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -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)) - - (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))) - - (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))) + (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) '()))) + + ;; 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) + + (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)) ;;; diff --git a/guix/build/pull.scm b/guix/build/pull.scm index e5b8797503..841787f0bb 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -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 diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm new file mode 100644 index 0000000000..a296bdf78f --- /dev/null +++ b/guix/build/store-copy.scm @@ -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 diff --git a/guix/gexp.scm b/guix/gexp.scm index e31324e101..ff80e305db 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -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))))))) diff --git a/guix/profiles.scm b/guix/profiles.scm index 55c3b6e768..9dc9ab43b9 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -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~%~}~%" diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 5e4647de79..09401e923c 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -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)) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm new file mode 100644 index 0000000000..83dde9a1a1 --- /dev/null +++ b/guix/scripts/lint.scm @@ -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))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 18af511ed8..b3b502425c 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -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." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 6ecf37e1a6..95c0130c95 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -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 diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index c2bf536e86..5dafb84f91 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -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)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 4f1869af38..7c0dde9030 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -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) diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index 0bb9f7559c..8c63bed0bf 100644 --- a/nix/nix-daemon/guix-daemon.cc +++ b/nix/nix-daemon/guix-daemon.cc @@ -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 @@ -326,6 +335,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); run (nothing); diff --git a/nix/sync-with-upstream b/nix/sync-with-upstream index 720fae132e..e9cb070dcc 100755 --- a/nix/sync-with-upstream +++ b/nix/sync-with-upstream @@ -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" \ diff --git a/po/guix/Makevars b/po/guix/Makevars index 87bb438418..f5b498caa9 100644 --- a/po/guix/Makevars +++ b/po/guix/Makevars @@ -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 diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index bf2d31306a..5cc68ff404 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -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 diff --git a/tests/derivations.scm b/tests/derivations.scm index 19bcebcb21..855b059d16 100644 --- a/tests/derivations.scm +++ b/tests/derivations.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" '())) diff --git a/tests/gexp.scm b/tests/gexp.scm index bf52401c66..ea4df48403 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -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")) diff --git a/tests/lint.scm b/tests/lint.scm new file mode 100644 index 0000000000..56558c904f --- /dev/null +++ b/tests/lint.scm @@ -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)) diff --git a/tests/profiles.scm b/tests/profiles.scm index 047c5ba49b..99f1fd2763 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -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 |