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