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

Merge branch 'master' into core-updates

Browse source
This commit is contained in:
Mark H Weaver 2015-06-18 01:32:37 -04:00
commit 2abf678682
26 changed files with 777 additions and 556 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
Makefile.am
View file

@ -113,6 +113,8 @@ MODULES = \
guix/scripts/import/hackage.scm \
guix/scripts/environment.scm \
guix/scripts/publish.scm \
guix/scripts/edit.scm \
guix/scripts/size.scm \
guix.scm \
$(GNU_SYSTEM_MODULES)
@ -191,7 +193,8 @@ SCM_TESTS = \
tests/syscalls.scm \
tests/gremlin.scm \
tests/lint.scm \
tests/publish.scm
tests/publish.scm \
tests/size.scm
if HAVE_GUILE_JSON
@ -264,7 +267,6 @@ EXTRA_DIST = \
build-aux/check-available-binaries.scm \
build-aux/check-final-inputs-self-contained.scm \
build-aux/download.scm \
build-aux/list-packages.scm \
build-aux/make-binary-tarball.scm \
srfi/srfi-37.scm.in \
srfi/srfi-64.scm \

16
build-aux/hydra/demo-os.scm
View file

@ -22,22 +22,14 @@
;;; machine images that we build.
;;;
(use-modules (gnu)
(gnu packages xorg)
(gnu packages avahi)
(gnu packages linux)
(gnu packages tor)
(gnu services networking)
(gnu services avahi)
(gnu services dbus)
(gnu services xorg))
(use-modules (gnu))
(use-service-modules desktop xorg networking avahi)
(use-package-modules linux xorg tor avahi)
(operating-system
(host-name "gnu")
(timezone "Europe/Paris")
(locale "en_US.utf8")
(locale "en_US.UTF-8")
(bootloader (grub-configuration
(device "/dev/sda")))

450
build-aux/list-packages.scm
View file

@ -1,450 +0,0 @@
#!/bin/sh
exec guile -l "$0" \
-c '(apply (@ (list-packages) list-packages)
(cdr (command-line)))'
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Alex Sassmannshausen <alex.sassmannshausen@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (list-packages)
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (guix licenses)
#:use-module (guix gnu-maintenance)
#:use-module ((guix download) #:select (%mirrors))
#:use-module ((guix build download) #:select (maybe-expand-mirrors))
#:use-module (gnu packages)
#:use-module (sxml simple)
#:use-module (sxml fold)
#:use-module (web uri)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (list-packages))
;;; Commentary:
;;;
;;; Emit an HTML representation of the packages available in GNU Guix.
;;;
;;; Code:
(define lookup-gnu-package
(let ((gnu (official-gnu-packages)))
(lambda (name)
"Return the package description for GNU package NAME, or #f."
(find (lambda (package)
(equal? (gnu-package-name package) name))
gnu))))
(define (list-join lst item)
"Join the items in LST by inserting ITEM between each pair of elements."
(let loop ((lst lst)
(result '()))
(match lst
(()
(match (reverse result)
(()
'())
((_ rest ...)
rest)))
((head tail ...)
(loop tail
(cons* head item result))))))
(define (package->sxml package previous description-ids remaining)
"Return 3 values: the HTML-as-SXML for PACKAGE added to all previously
collected package output in PREVIOUS, a list of DESCRIPTION-IDS and the number
of packages still to be processed in REMAINING. Also Introduces a call to the
JavaScript prep_pkg_descs function as part of the output of PACKAGE, every
time the length of DESCRIPTION-IDS, increasing, is 15 or when REMAINING,
decreasing, is 1."
(define (location-url loc)
(string-append "http://git.savannah.gnu.org/cgit/guix.git/tree/"
(location-file loc) "#n"
(number->string (location-line loc))))
(define (source-url package)
(let ((loc (package-location package)))
(and loc (location-url loc))))
(define (license package)
(define ->sxml
(match-lambda
((lst ...)
`(div ,(map ->sxml lst)))
((? license? license)
(let ((uri (license-uri license)))
(case (and=> (and uri (string->uri uri)) uri-scheme)
((http https)
`(div (a (@ (href ,uri)
(title "Link to the full license"))
,(license-name license))))
(else
`(div ,(license-name license) " ("
,(license-comment license) ")")))))
(#f "")))
(->sxml (package-license package)))
(define (patches package)
(define patch-url
(match-lambda
((? string? patch)
(string-append
"http://git.savannah.gnu.org/cgit/guix.git/tree/gnu/packages/patches/"
(basename patch)))
((? origin? patch)
(uri->string
(first (maybe-expand-mirrors (string->uri
(match (origin-uri patch)
((? string? uri) uri)
((head . tail) head)))
%mirrors))))))
(define patch-name
(match-lambda
((? string? patch)
(basename patch))
((? origin? patch)
(match (origin-uri patch)
((? string? uri) (basename uri))
((head . tail) (basename head))))))
(define (snippet-link snippet)
(let ((loc (or (package-field-location package 'source)
(package-location package))))
`(a (@ (href ,(location-url loc))
(title "Link to patch snippet"))
"snippet")))
(and (origin? (package-source package))
(let ((patches (origin-patches (package-source package)))
(snippet (origin-snippet (package-source package))))
(and (or (pair? patches) snippet)
`(div "patches: "
,(let loop ((patches patches)
(number 1)
(links '()))
(match patches
(()
(let* ((additional (and snippet
(snippet-link snippet)))
(links (if additional
(cons additional links)
links)))
(list-join (reverse links) ", ")))
((patch rest ...)
(loop rest
(+ 1 number)
(cons `(a (@ (href ,(patch-url patch))
(title ,(string-append
"Link to "
(patch-name patch))))
,(number->string number))
links))))))))))
(define (status package)
(define (url system)
`(a (@ (href ,(string-append "http://hydra.gnu.org/job/gnu/master/"
(package-full-name package) "."
system))
(title "View the status of this architecture's build at Hydra"))
,system))
`(div "status: "
,(list-join (map url
(lset-intersection
string=?
%hydra-supported-systems
(package-transitive-supported-systems package)))
" ")))
(define (package-logo name)
(and=> (lookup-gnu-package name)
gnu-package-logo))
(define (insert-tr description-id js?)
(define (insert-js-call description-ids)
"Return an sxml call to prep_pkg_descs, with up to 15 elements of
description-ids as formal parameters."
`(script (@ (type "text/javascript"))
,(format #f "prep_pkg_descs(~a)"
(string-append "'"
(string-join description-ids "', '")
"'"))))
(let ((description-ids (cons description-id description-ids)))
`(tr (td ,(if (gnu-package? package)
`(img (@ (src "/graphics/gnu-head-mini.png")
(alt "Part of GNU")
(title "Part of GNU")))
""))
(td (a (@ (href ,(source-url package))
(title "Link to the Guix package source code"))
,(package-name package) " "
,(package-version package)))
(td (span ,(package-synopsis package))
(div (@ (id ,description-id))
,(match (package-logo (package-name package))
((? string? url)
`(img (@ (src ,url)
(height "35")
(class "package-logo")
(alt ("Logo of " ,(package-name package))))))
(_ #f))
(p ,(package-description package))
,(license package)
(a (@ (href ,(package-home-page package))
(title "Link to the package's website"))
,(package-home-page package))
,(status package)
,(patches package)
,(if js?
(insert-js-call description-ids)
""))))))
(let ((description-id (symbol->string
(gensym (package-name package)))))
(cond ((= remaining 1) ; Last package in packages
(values
(reverse ; Fold has reversed packages
(cons (insert-tr description-id 'js) ; Prefix final sxml
previous))
'() ; No more work to do
0)) ; End of the line
((= (length description-ids) 15) ; Time for a JS call
(values
(cons (insert-tr description-id 'js)
previous) ; Prefix new sxml
'() ; Reset description-ids
(1- remaining))) ; Reduce remaining
(else ; Insert another row, and build description-ids
(values
(cons (insert-tr description-id #f)
previous) ; Prefix new sxml
(cons description-id description-ids) ; Update description-ids
(1- remaining)))))) ; Reduce remaining
(define (packages->sxml packages)
"Return an HTML page as SXML describing PACKAGES."
`(div
(h2 "GNU Guix Package List")
(div (@ (id "intro"))
(div
(img (@ (src "graphics/GuixSD-V.png")
(alt "Guix System Distribution")
(height "83"))))
(p "This web page lists the packages currently provided by the "
(a (@ (href "manual/guix.html#GNU-Distribution"))
"Guix System Distribution")
". "
"Our " (a (@ (href "http://hydra.gnu.org/jobset/gnu/master"))
"continuous integration system")
" shows their current build status."))
(table (@ (id "packages"))
(tr (th "GNU?")
(th "Package version")
(th "Package details"))
,@(fold-values package->sxml packages '() '() (length packages)))
(a (@ (href "#intro")
(title "Back to top.")
(id "top"))
"^")))
(define (insert-css)
"Return the CSS for the list-packages page."
(format #t
"<style>
/* license: CC0 */
a {
transition: all 0.3s;
}
div#intro {
margin-bottom: 2em;
}
div#intro div, div#intro p {
padding:0.5em;
}
div#intro div {
float:left;
}
div#intro img {
float:left;
padding:0.75em;
}
table#packages, table#packages tr, table#packages tbody, table#packages td, table#packages th {
border: 0px solid black;
clear: both;
}
table#packages tr:nth-child(even) {
background-color: #FFF;
}
table#packages tr:nth-child(odd) {
background-color: #EEE;
}
table#packages tr:hover, table#packages tr:focus, table#packages tr:active {
background-color: #DDD;
}
table#packages tr:first-child, table#packages tr:first-child:hover, table#packages tr:first-child:focus, table#packages tr:first-child:active {
background-color: #333;
color: #fff;
}
table#packages td {
margin:0px;
padding:0.2em 0.5em;
}
table#packages td:first-child {
width:10%;
text-align:center;
}
table#packages td:nth-child(2) {
width:30%;
}
table#packages td:last-child {
width:60%;
}
img.package-logo {
float: left;
padding: 0.75em;
}
table#packages span {
font-weight: 700;
}
table#packages span a {
float: right;
font-weight: 500;
}
a#top {
position:fixed;
right:10px;
bottom:10px;
font-size:150%;
background-color:#EEE;
padding:10px 7.5px 0 7.5px;
text-decoration:none;
color:#000;
border-radius:5px;
}
a#top:hover, a#top:focus {
background-color:#333;
color:#fff;
}
</style>"))
(define (insert-js)
"Return the JavaScript for the list-packages page."
(format #t
"<script type=\"text/javascript\">
// license: CC0
function show_hide(idThing)
{
if(document.getElementById && document.createTextNode) {
var thing = document.getElementById(idThing);
/* Used to change the link text, depending on whether description is
collapsed or expanded */
var thingLink = thing.previousSibling.lastChild.firstChild;
if (thing) {
if (thing.style.display == \"none\") {
thing.style.display = \"\";
thingLink.data = 'Collapse';
} else {
thing.style.display = \"none\";
thingLink.data = 'Expand';
}
}
}
}
/* Add controllers used for collapse/expansion of package descriptions */
function prep(idThing)
{
var tdThing = document.getElementById(idThing).parentNode;
if (tdThing) {
var aThing = tdThing.firstChild.appendChild(document.createElement('a'));
aThing.setAttribute('href', 'javascript:void(0)');
aThing.setAttribute('title', 'show/hide package description');
aThing.appendChild(document.createTextNode('Expand'));
aThing.onclick=function(){show_hide(idThing);};
/* aThing.onkeypress=function(){show_hide(idThing);}; */
}
}
/* Take n element IDs, prepare them for javascript enhanced
display and hide the IDs by default. */
function prep_pkg_descs()
{
if(document.getElementById && document.createTextNode) {
for(var i=0; i<arguments.length; i++) {
prep(arguments[i])
show_hide(arguments[i]);
}
}
}
</script>"))
(define (list-packages . args)
"Return an HTML page listing all the packages found in the GNU distribution,
with gnu.org server-side include and all that."
;; Don't attempt to translate descriptions.
(setlocale LC_ALL "C")
;; Output the page as UTF-8 since that's what the gnu.org server-side
;; headers claim.
(set-port-encoding! (current-output-port) "UTF-8")
(let ((packages (sort (fold-packages cons '())
(lambda (p1 p2)
(string<? (package-name p1) (package-name p2))))))
(format #t "<!--#include virtual=\"/server/html5-header.html\" -->
<!-- Parent-Version: 1.70 $ -->
<title>GNU Guix - GNU Distribution - GNU Project</title>
")
(insert-css)
(insert-js)
(format #t "<!--#include virtual=\"/server/banner.html\" -->")
(sxml->xml (packages->sxml packages))
(format #t "</div>
<!--#include virtual=\"/server/footer.html\" -->
<div id=\"footer\">
<p>Please send general FSF &amp; GNU inquiries to
<a href=\"mailto:gnu@gnu.org\">&lt;gnu@gnu.org&gt;</a>.
There are also <a href=\"/contact/\">other ways to contact</a>
the FSF. Broken links and other corrections or suggestions can be sent
to <a href=\"mailto:bug-guix@gnu.org\">&lt;bug-guix@gnu.org&gt;</a>.</p>
<p>Copyright &copy; 2013 Free Software Foundation, Inc.</p>
<p>This page is licensed under a <a rel=\"license\"
href=\"http://creativecommons.org/licenses/by-nd/3.0/us/\">Creative
Commons Attribution-NoDerivs 3.0 United States License</a>.</p>
<p>Updated:
<!-- timestamp start -->
$Date$
<!-- timestamp end -->
</p>
</div>
</div>
</body>
</html>
"))
)
;;; list-packages.scm ends here

10
doc.am
View file

@ -90,6 +90,7 @@ SUBCOMMANDS := \
archive \
build \
download \
edit \
environment \
gc \
hash \
@ -99,6 +100,7 @@ SUBCOMMANDS := \
publish \
pull \
refresh \
size \
system
$(eval $(foreach subcommand,$(SUBCOMMANDS), \
@ -106,5 +108,11 @@ $(eval $(foreach subcommand,$(SUBCOMMANDS), \
dist_man1_MANS = \
doc/guix.1 \
doc/guix-daemon.1 \
$(SUBCOMMANDS:%=doc/guix-%.1)
if BUILD_DAEMON
dist_man1_MANS += \
doc/guix-daemon.1
endif

28
doc/contributing.texi
View file

@ -203,14 +203,32 @@ standards, GNU Coding Standards}); you can check the commit history for
examples.
Before submitting a patch that adds or modifies a package definition,
please run @code{guix lint @var{package}}, where @var{package} is the
please run through this check list:
@enumerate
@item
Run @code{guix lint @var{package}}, where @var{package} is the
name of the new or modified package, and fix any errors it reports
(@pxref{Invoking guix lint}). In addition, please make sure the package
builds on your platform, using @code{guix build @var{package}}. You may
also want to check that dependent package (if applicable) are not
affected by the change; @code{guix refresh --list-dependent
(@pxref{Invoking guix lint}).
@item
Make sure the package builds on your platform, using @code{guix build
@var{package}}.
@item
Take a look at the profile reported by @command{guix size}
(@pxref{Invoking guix size}). This will allow you to notice references
to other packages unwillingly retained. It may also help determine
whether to split the package (@pxref{Packages with Multiple Outputs}),
and which optional dependencies should be used.
@item
For important changes, check that dependent package (if applicable) are
not affected by the change; @code{guix refresh --list-dependent
@var{package}} will help you do that (@pxref{Invoking guix refresh}).
@end enumerate
When posting a patch to the mailing list, use @samp{[PATCH] @dots{}} as a
subject. You may use your email client or the @command{git send-mail}
command.

109
doc/guix.texi
View file

@ -124,11 +124,13 @@ Defining Packages
Utilities
* Invoking guix build:: Building packages from the command line.
* Invoking guix edit:: Editing package definitions.
* Invoking guix download:: Downloading a file and printing its hash.
* Invoking guix hash:: Computing the cryptographic hash of a file.
* Invoking guix import:: Importing package definitions.
* Invoking guix refresh:: Updating package definitions.
* Invoking guix lint:: Finding errors in package definitions.
* Invoking guix size:: Profiling disk usage.
* Invoking guix environment:: Setting up development environments.
* Invoking guix publish:: Sharing substitutes.
@ -1494,7 +1496,8 @@ graphical user interfaces (GUIs). The former depend solely on the C
library, whereas the latter depend on Tcl/Tk and the underlying X
libraries. In this case, we leave the command-line tools in the default
output, whereas the GUIs are in a separate output. This allows users
who do not need the GUIs to save space.
who do not need the GUIs to save space. The @command{guix size} command
can help find out about such situations (@pxref{Invoking guix size}).
There are several such multiple-output packages in the GNU distribution.
Other conventional output names include @code{lib} for libraries and
@ -1574,11 +1577,15 @@ as arguments.
@item --requisites
@itemx -R
@cindex closure
List the requisites of the store files passed as arguments. Requisites
include the store files themselves, their references, and the references
of these, recursively. In other words, the returned list is the
@dfn{transitive closure} of the store files.
@xref{Invoking guix size}, for a tool to profile the size of an
element's closure.
@end table
Lastly, the following options allow you to check the integrity of the
@ -1931,7 +1938,10 @@ unavailable to the build process, possibly leading to a build failure.
Once a package definition is in place, the
package may actually be built using the @code{guix build} command-line
tool (@pxref{Invoking guix build}). @xref{Packaging Guidelines}, for
tool (@pxref{Invoking guix build}). You can easily jump back to the
package definition using the @command{guix edit} command
(@pxref{Invoking guix edit}).
@xref{Packaging Guidelines}, for
more information on how to test package definitions, and
@ref{Invoking guix lint}, for information on how to check a definition
for style conformance.
@ -3261,11 +3271,13 @@ programming interface of Guix in a convenient way.
@menu
* Invoking guix build:: Building packages from the command line.
* Invoking guix edit:: Editing package definitions.
* Invoking guix download:: Downloading a file and printing its hash.
* Invoking guix hash:: Computing the cryptographic hash of a file.
* Invoking guix import:: Importing package definitions.
* Invoking guix refresh:: Updating package definitions.
* Invoking guix lint:: Finding errors in package definitions.
* Invoking guix size:: Profiling disk usage.
* Invoking guix environment:: Setting up development environments.
* Invoking guix publish:: Sharing substitutes.
@end menu
@ -3548,6 +3560,28 @@ the parsed command-line options.
@end defvr
@node Invoking guix edit
@section Invoking @command{guix edit}
@cindex package definition, editing
So many packages, so many source files! The @command{guix edit} command
facilitates the life of packagers by pointing their editor at the source
file containing the definition of the specified packages. For instance:
@example
guix edit gcc-4.8 vim
@end example
@noindent
launches the program specified in the @code{EDITOR} environment variable
to edit the recipe of GCC@tie{}4.8.4 and that of Vim.
If you are using Emacs, note that the Emacs user interface provides
similar functionality in the ``package info'' buffers created by
@kbd{M-x guix-search-by-name} and similar commands (@pxref{Emacs
Commands}).
@node Invoking guix download
@section Invoking @command{guix download}
@ -3947,6 +3981,73 @@ and exit.
@end table
@node Invoking guix size
@section Invoking @command{guix size}
The @command{guix size} command helps package developers profile the
disk usage of packages. It is easy to overlook the impact of an
additional dependency added to a package, or the impact of using a
single output for a package that could easily be split (@pxref{Packages
with Multiple Outputs}). These are the typical issues that
@command{guix size} can highlight.
The command can be passed a package specification such as @code{gcc-4.8}
or @code{guile:debug}, or a file name in the store. Consider this
example:
@example
$ guix size coreutils
store item total self
/gnu/store/@dots{}-coreutils-8.23 70.0 13.9 19.8%
/gnu/store/@dots{}-gmp-6.0.0a 55.3 2.5 3.6%
/gnu/store/@dots{}-acl-2.2.52 53.7 0.5 0.7%
/gnu/store/@dots{}-attr-2.4.46 53.2 0.3 0.5%
/gnu/store/@dots{}-gcc-4.8.4-lib 52.9 15.7 22.4%
/gnu/store/@dots{}-glibc-2.21 37.2 37.2 53.1%
@end example
@cindex closure
The store items listed here constitute the @dfn{transitive closure} of
Coreutils---i.e., Coreutils and all its dependencies, recursively---as
would be returned by:
@example
$ guix gc -R /gnu/store/@dots{}-coreutils-8.23
@end example
Here the output shows 3 columns next to store items. The first column,
labeled ``total'', shows the size in mebibytes (MiB) of the closure of
the store item---that is, its own size plus the size of all its
dependencies. The next column, labeled ``self'', shows the size of the
item itself. The last column shows the ratio of the item's size to the
space occupied by all the items listed here.
In this example, we see that the closure of Coreutils weighs in at
70@tie{}MiB, half of which is taken by libc. (That libc represents a
large fraction of the closure is not a problem @i{per se} because it is
always available on the system anyway.)
When the package passed to @command{guix size} is available in the
store, @command{guix size} queries the daemon to determine its
dependencies, and measures its size in the store, similar to @command{du
-ms --apparent-size} (@pxref{du invocation,,, coreutils, GNU
Coreutils}).
When the given package is @emph{not} in the store, @command{guix size}
reports information based on information about the available substitutes
(@pxref{Substitutes}). This allows it to profile disk usage of store
items that are not even on disk, only available remotely.
A single option is available:
@table @option
@item --system=@var{system}
@itemx -s @var{system}
Consider packages for @var{system}---e.g., @code{x86_64-linux}.
@end table
@node Invoking guix environment
@section Invoking @command{guix environment}
@ -4606,8 +4707,8 @@ Linux @dfn{pluggable authentication module} (PAM) services.
List of string-valued G-expressions denoting setuid programs.
@xref{Setuid Programs}.
@item @code{sudoers} (default: @var{%sudoers-specification})
@cindex sudoers
@item @code{sudoers-file} (default: @var{%sudoers-specification})
@cindex sudoers file
The contents of the @file{/etc/sudoers} file as a file-like object
(@pxref{G-Expressions, @code{local-file} and @code{plain-file}}).

20
gnu/build/install.scm
View file

@ -161,20 +161,27 @@ (define (reset-timestamps directory)
(utime file 0 0 0 0))))
(find-files directory "")))
(define (register-closure store closure)
(define* (register-closure store closure
#:key (deduplicate? #t))
"Register CLOSURE in STORE, where STORE is the directory name of the target
store and CLOSURE is the name of a file containing a reference graph as used
by 'guix-register'. As a side effect, this resets timestamps on store files."
(let ((status (system* "guix-register" "--prefix" store
closure)))
by 'guix-register'. As a side effect, this resets timestamps on store files
and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the
rest of STORE."
(let ((status (apply system* "guix-register" "--prefix" store
(append (if deduplicate? '() '("--no-deduplication"))
(list closure)))))
(unless (zero? status)
(error "failed to register store items" closure))))
(define* (populate-single-profile-directory directory
#:key profile closure)
#:key profile closure
deduplicate?)
"Populate DIRECTORY with a store containing PROFILE, whose closure is given
in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY
is initialized to contain a single profile under /root pointing to PROFILE.
DEDUPLICATE? determines whether to deduplicate files in the store.
This is used to create the self-contained Guix tarball."
(define (scope file)
(string-append directory "/" file))
@ -190,7 +197,8 @@ (define (symlink* old new)
;; Populate the store.
(populate-store (list closure) directory)
(register-closure (canonicalize-path directory) closure)
(register-closure (canonicalize-path directory) closure
#:deduplicate? deduplicate?)
;; XXX: 'guix-register' registers profiles as GC roots but the symlink
;; target uses $TMPDIR. Fix that.

36
gnu/packages.scm
View file

@ -51,7 +51,8 @@ (define-module (gnu packages)
check-package-freshness
specification->package))
specification->package
specification->package+output))
;;; Commentary:
;;;
@ -418,3 +419,36 @@ (define (specification->package spec)
(leave (_ "~A: package not found for version ~a~%")
name version)
(leave (_ "~A: unknown package~%") name))))))
(define* (specification->package+output spec #:optional (output "out"))
"Return the package and output specified by SPEC, or #f and #f; SPEC may
optionally contain a version number and an output name, as in these examples:
guile
guile-2.0.9
guile:debug
guile-2.0.9:debug
If SPEC does not specify a version number, return the preferred newest
version; if SPEC does not specify an output, return OUTPUT."
(define (ensure-output p sub-drv)
(if (member sub-drv (package-outputs p))
sub-drv
(leave (_ "package `~a' lacks output `~a'~%")
(package-full-name p)
sub-drv)))
(let-values (((name version sub-drv)
(package-specification->name+version+output spec output)))
(match (find-best-packages-by-name name version)
((p)
(values p (ensure-output p sub-drv)))
((p p* ...)
(warning (_ "ambiguous package specification `~a'~%")
spec)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
(values p (ensure-output p sub-drv)))
(()
(leave (_ "~a: package not found~%") spec)))))

58
gnu/packages/bioinformatics.scm
View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2015 Ben Woodcroft <donttrustben@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -28,6 +29,7 @@ (define-module (gnu packages bioinformatics)
#:use-module (guix build-system python)
#:use-module (guix build-system trivial)
#:use-module (gnu packages)
#:use-module (gnu packages algebra)
#:use-module (gnu packages base)
#:use-module (gnu packages boost)
#:use-module (gnu packages compression)
@ -87,7 +89,7 @@ (define-public bamtools
(define-public bedops
(package
(name "bedops")
(version "2.4.5")
(version "2.4.14")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/bedops/bedops/archive/v"
@ -95,7 +97,7 @@ (define-public bedops
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"0wmg6j0icimlrnsidaxrzf3hfgjvlkkcwvpdg7n4gg7hdv2m9ni5"))))
"1kqbac547wyqma81cyky9n7mkgikjpsfd3nnmcm6hpqwanqgh10v"))))
(build-system gnu-build-system)
(arguments
'(#:tests? #f
@ -615,6 +617,56 @@ (define-public cutadapt
other types of unwanted sequence from high-throughput sequencing reads.")
(license license:expat)))
(define-public diamond
(package
(name "diamond")
(version "0.7.9")
(source (origin
(method url-fetch)
(uri (string-append
"https://github.com/bbuchfink/diamond/archive/v"
version ".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"0hfkcfv9f76h5brbyw9fyvmc0l9cmbsxrcdqk0fa9xv82zj47p15"))
(snippet '(begin
(delete-file "bin/diamond")
#t))))
(build-system gnu-build-system)
(arguments
'(#:tests? #f ;no "check" target
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'enter-source-dir
(lambda _
(chdir "src")
#t))
(delete 'configure)
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(let ((bin (string-append (assoc-ref outputs "out")
"/bin")))
(mkdir-p bin)
(copy-file "../bin/diamond"
(string-append bin "/diamond"))
#t))))))
(native-inputs
`(("bc" ,bc)))
(inputs
`(("boost" ,boost)
("zlib" ,zlib)))
(home-page "https://github.com/bbuchfink/diamond")
(synopsis "Accelerated BLAST compatible local sequence aligner")
(description
"DIAMOND is a BLAST-compatible local aligner for mapping protein and
translated DNA query sequences against a protein reference database (BLASTP
and BLASTX alignment mode). The speedup over BLAST is up to 20,000 on short
reads at a typical sensitivity of 90-99% relative to BLAST depending on the
data and settings.")
(license (license:non-copyleft "file://src/COPYING"
"See src/COPYING in the distribution."))))
(define-public edirect
(package
(name "edirect")
@ -1063,7 +1115,7 @@ (define-public miso
(source (origin
(method url-fetch)
(uri (string-append
"http://pypi.python.org/packages/source/m/misopy/misopy-"
"https://pypi.python.org/packages/source/m/misopy/misopy-"
version ".tar.gz"))
(sha256
(base32

4
gnu/packages/ebook.scm
View file

@ -60,7 +60,7 @@ (define-public chmlib
(define-public calibre
(package
(name "calibre")
(version "2.29.0")
(version "2.30.0")
(source
(origin
(method url-fetch)
@ -69,7 +69,7 @@ (define-public calibre
version ".tar.xz"))
(sha256
(base32
"1n3cfnjnghhhsgzcbcvbr0gh191lhl6az09q1s68jhlcc2lski6l"))
"1k2rpn06nfzqjy5k6fh8pwfj8vbhpn7rgkpkkpz5n2fqg3z8ph1j"))
;; Remove non-free or doubtful code, see
;; https://lists.gnu.org/archive/html/guix-devel/2015-02/msg00478.html
(modules '((guix build utils)))

37
gnu/packages/freedesktop.scm
View file

@ -38,7 +38,9 @@ (define-module (gnu packages freedesktop)
#:use-module (gnu packages docbook)
#:use-module (gnu packages glib) ;intltool
#:use-module (gnu packages xdisorg)
#:use-module (gnu packages xorg))
#:use-module (gnu packages xorg)
#:use-module (gnu packages doxygen)
#:use-module (gnu packages libffi))
(define-public xdg-utils
(package
@ -197,3 +199,36 @@ (define-public python-pyxdg
(define-public python2-pyxdg
(package-with-python2 python-pyxdg))
(define-public wayland
(package
(name "wayland")
(version "1.8.1")
(source (origin
(method url-fetch)
(uri (string-append "http://wayland.freedesktop.org/releases/"
name "-" version ".tar.xz"))
(sha256
(base32
"1j3gfzn8i0xhk3j34mwb2srrscjxfyi279jhyq80mz943j6r6z7i"))))
(build-system gnu-build-system)
(native-inputs
`(("doxygen" ,doxygen)
("pkg-config" ,pkg-config)
("xmlto" ,xmlto)
("xsltproc" ,libxslt)))
(inputs
`(("docbook-xml" ,docbook-xml)
("docbook-xsl" ,docbook-xsl)
("expat" ,expat)
("libffi" ,libffi)
("libxml2" ,libxml2))) ; for XML_CATALOG_FILES
(home-page "http://wayland.freedesktop.org/")
(synopsis "Display server protocol")
(description
"Wayland is a protocol for a compositor to talk to its clients as well as
a C library implementation of that protocol. The compositor can be a standalone
display server running on Linux kernel modesetting and evdev input devices, an X
application, or a wayland client itself. The clients can be traditional
applications, X servers (rootless or fullscreen) or other display servers.")
(license license:x11)))

23
gnu/packages/image.scm
View file

@ -582,3 +582,26 @@ (define-public libwebp
to PNG when lossy compression is acceptable for the red/green/blue color
channels.")
(license license:bsd-3)))
(define-public libmng
(package
(name "libmng")
(version "2.0.3")
(source (origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/libmng/"
name "-" version ".tar.xz"))
(sha256
(base32
"1lvxnpds0vcf0lil6ia2036ghqlbl740c4d2sz0q5g6l93fjyija"))))
(build-system gnu-build-system)
(propagated-inputs
;; These are all in the 'Libs.private' field of libmng.pc.
`(("lcms" ,lcms)
("libjpeg" ,libjpeg)
("zlib" ,zlib)))
(home-page "http://www.libmng.com/")
(synopsis "Library for handling MNG files")
(description
"Libmng is the MNG (Multiple-image Network Graphics) reference library.")
(license license:bsd-3)))

7
gnu/packages/ocaml.scm
View file

@ -24,12 +24,12 @@ (define-module (gnu packages ocaml)
#:use-module (guix utils)
#:use-module (guix build-system gnu)
#:use-module (gnu packages)
#:use-module (gnu packages gcc)
#:use-module (gnu packages base)
#:use-module (gnu packages emacs)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages compression)
#:use-module (gnu packages commencement)
#:use-module (gnu packages xorg)
#:use-module (gnu packages texlive)
#:use-module (gnu packages perl)
@ -57,8 +57,9 @@ (define-public ocaml
("pkg-config" ,pkg-config)))
(inputs
`(("libx11" ,libx11)
("gcc:lib" ,gcc-final "lib") ; for libiberty, needed for objdump support
("zlib" ,zlib))) ; also needed for objdump support
;; For libiberty, needed for objdump support.
("gcc:lib" ,(canonical-package gcc-4.8) "lib")
("zlib" ,zlib))) ;also needed for objdump support
(arguments
`(#:modules ((guix build gnu-build-system)
(guix build utils)

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

@ -166,7 +166,7 @@ (define guix-devel
;;
;; Note: use a short commit id; when using the long one, the limit on socket
;; file names is exceeded while running the tests.
(let ((commit "a43b55f"))
(let ((commit "684bf7c"))
(package (inherit guix-0.8.2)
(version (string-append "0.8.2." commit))
(source (origin
@ -176,7 +176,7 @@ (define guix-devel
(commit commit)))
(sha256
(base32
"1r0l8gfh5nxc1j0sqj8ywkg280k9qbj7zsk33z84rvl7l0nwnk88"))
"0fq9ajj17kbb0f1p79al2vcqah9sl0imayhggcp31c3vq0ahya9g"))
(file-name (string-append "guix-" version "-checkout"))))
(arguments
(substitute-keyword-arguments (package-arguments guix-0.8.2)

14
gnu/packages/qt.scm
View file

@ -29,6 +29,8 @@ (define-module (gnu packages qt)
#:use-module (gnu packages)
#:use-module (gnu packages bison)
#:use-module (gnu packages compression)
#:use-module (gnu packages cups)
#:use-module (gnu packages databases)
#:use-module (gnu packages fontutils)
#:use-module (gnu packages flex)
#:use-module (gnu packages gl)
@ -93,7 +95,7 @@ (define-public libxkbcommon
(define-public qt
(package
(name "qt")
(version "5.4.1")
(version "5.4.2")
(source (origin
(method url-fetch)
(uri (string-append "http://download.qt-project.org/official_releases/qt/"
@ -103,7 +105,7 @@ (define-public qt
version ".tar.xz"))
(sha256
(base32
"0q6qzakq8xihw91xv310qi3vyylq7x2bzdkjgy8sqxii2lgbjzhv"))
"09gay5cimfdb0apy60v7z4r4zkl2vjysdppzihpla8dp2c30fvcc"))
(patches (list (search-patch "qt5-conflicting-typedefs.patch")
(search-patch "qt5-runpath.patch")))
(snippet
@ -119,12 +121,14 @@ (define-public qt
(inputs
`(("alsa-lib" ,alsa-lib)
("dbus" ,dbus)
("cups" ,cups)
("expat" ,expat)
("fontconfig" ,fontconfig)
("freetype" ,freetype)
("glib" ,glib)
("icu4c" ,icu4c)
("libjpeg" ,libjpeg)
("libmng" ,libmng)
("libpci" ,pciutils)
("libpng" ,libpng)
("libx11" ,libx11)
@ -143,10 +147,12 @@ (define-public qt
("mysql" ,mysql)
("nss" ,nss)
("openssl" ,openssl)
("postgresql" ,postgresql)
("pulseaudio" ,pulseaudio)
("pcre" ,pcre)
("sqlite" ,sqlite)
("udev" ,eudev)
("unixodbc" ,unixodbc)
("xcb-util" ,xcb-util)
("xcb-util-image" ,xcb-util-image)
("xcb-util-keysyms" ,xcb-util-keysyms)
@ -221,7 +227,7 @@ (define-public qt
(define-public qt-4
(package (inherit qt)
(version "4.8.6")
(version "4.8.7")
(source (origin
(method url-fetch)
(uri (string-append "http://download.qt-project.org/official_releases/qt/"
@ -231,7 +237,7 @@ (define-public qt-4
version ".tar.gz"))
(sha256
(base32
"0b036iqgmbbv37dgwwfihw3mihjbnw3kb5kaisdy0qi8nn8xs54b"))
"183fca7n7439nlhxyg1z7aky0izgbyll3iwakw4gwivy16aj5272"))
(patches (map search-patch
'("qt4-ldflags.patch" "qt4-tests.patch")))))
(inputs `(,@(alist-delete "libjpeg" (package-inputs qt))

6
gnu/packages/samba.scm
View file

@ -168,14 +168,14 @@ (define-public samba
(define-public talloc
(package
(name "talloc")
(version "2.1.0")
(version "2.1.2")
(source (origin
(method url-fetch)
(uri (string-append "http://www.samba.org/ftp/talloc/talloc-"
(uri (string-append "https://www.samba.org/ftp/talloc/talloc-"
version ".tar.gz"))
(sha256
(base32
"13zh628hzlp2v9vj70knnfac2xbxqrdhgap30csq4zv4h8w3j087"))))
"13c365f7y8idjf2v1jxdjpkc3lxdmsxxfxjx1ymianm7zjiph393"))))
(build-system gnu-build-system)
(arguments
'(#:phases (alist-replace

15
gnu/system.scm
View file

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -148,8 +149,8 @@ (define-record-type* <operating-system> operating-system
(setuid-programs operating-system-setuid-programs
(default %setuid-programs)) ; list of string-valued gexps
(sudoers operating-system-sudoers ; file-like
(default %sudoers-specification)))
(sudoers-file operating-system-sudoers-file ; file-like
(default %sudoers-specification)))
;;;
@ -440,7 +441,7 @@ (define* (etc-directory #:key
(pam-services '())
(profile "/run/current-system/profile")
hosts-file nss (shells '())
(sudoers (plain-file "sudoers" "")))
(sudoers-file (plain-file "sudoers" "")))
"Return a derivation that builds the static part of the /etc directory."
(mlet* %store-monad
((pam.d (pam-services->directory pam-services))
@ -540,7 +541,7 @@ (define* (etc-directory #:key
("hosts" ,#~#$hosts-file)
("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
#$timezone))
("sudoers" ,sudoers)))))
("sudoers" ,sudoers-file)))))
(define (operating-system-profile os)
"Return a derivation that builds the system profile of OS."
@ -624,9 +625,9 @@ (define (operating-system-etc-directory os)
#:timezone (operating-system-timezone os)
#:hosts-file /etc/hosts
#:shells shells
#:sudoers (maybe-string->file
"sudoers"
(operating-system-sudoers os))
#:sudoers-file (maybe-string->file
"sudoers"
(operating-system-sudoers-file os))
#:profile profile-drv)))
(define %setuid-programs

6
gnu/system/install.scm
View file

@ -63,15 +63,19 @@ (define %root "root")
(setenv "PATH"
(string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin"))
;; Note: there is not much to gain here with deduplication and there
;; is the overhead of the '.links' directory, so turn it off.
(populate-single-profile-directory %root
#:profile #$profile
#:closure "profile")
#:closure "profile"
#:deduplicate? #f)
;; Create the tarball. Use GNU format so there's no file name
;; length limitation.
(with-directory-excursion %root
(zero? (system* "tar" "--xz" "--format=gnu"
"--owner=root:0" "--group=root:0"
"--check-links"
"-cvf" #$output
;; Avoid adding / and /var to the tarball,
;; so that the ownership and permissions of those

25
guix/gnu-maintenance.scm
View file

@ -192,15 +192,22 @@ (define (mirror-type url)
;; Definitely non-GNU.
'non-gnu)))))
(let ((url (and=> (package-source package) origin-uri))
(name (package-name package)))
(case (and (string? url) (mirror-type url))
((gnu) #t)
((non-gnu) #f)
(else
;; Last resort: resort to the network.
(and (member name (map gnu-package-name (official-gnu-packages)))
#t))))))))
(define (gnu-home-page? package)
(and=> (package-home-page package)
(lambda (url)
(and=> (uri-host (string->uri url))
(lambda (host)
(member host '("www.gnu.org" "gnu.org")))))))
(or (gnu-home-page? package)
(let ((url (and=> (package-source package) origin-uri))
(name (package-name package)))
(case (and (string? url) (mirror-type url))
((gnu) #t)
((non-gnu) #f)
(else
(and (member name (map gnu-package-name (official-gnu-packages)))
#t)))))))))
;;;

4
guix/scripts/archive.scm
View file

@ -27,6 +27,8 @@ (define-module (guix scripts archive)
#:use-module (guix ui)
#:use-module (guix pki)
#:use-module (guix pk-crypto)
#:use-module (guix scripts build)
#:use-module (gnu packages)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 rdelim)
@ -34,8 +36,6 @@ (define-module (guix scripts archive)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (guix scripts build)
#:use-module (guix scripts package)
#:use-module (rnrs io ports)
#:export (guix-archive))

79
guix/scripts/edit.scm Normal file
View file

@ -0,0 +1,79 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts edit)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (gnu packages)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-37)
#:export (%editor
guix-edit))
(define %options
(list (option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix edit")))))
(define (show-help)
(display (_ "Usage: guix edit PACKAGE...
Start $EDITOR to edit the definitions of PACKAGE...\n"))
(newline)
(display (_ "
-h, --help display this help and exit"))
(display (_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(define %editor
(make-parameter (or (getenv "EDITOR") "emacsclient")))
(define (search-path* path file)
"Like 'search-path' but exit if FILE is not found."
(let ((absolute-file-name (search-path path file)))
(unless absolute-file-name
;; Shouldn't happen unless somebody fiddled with the 'location' field.
(leave (_ "file '~a' not found in search path ~s~%")
file path))
absolute-file-name))
(define (guix-edit . args)
(with-error-handling
(let* ((specs (parse-command-line args %options '(())
#:argument-handler cons))
(packages (map specification->package specs)))
(for-each (lambda (package)
(unless (package-location package)
(leave (_ "source location of package '~a' is unknown~%")
(package-full-name package))))
packages)
(apply execlp (%editor) (%editor)
(append-map (lambda (package)
(let ((loc (package-location package)))
(list (string-append "+"
(number->string
(location-line loc)))
(search-path* %load-path (location-file loc)))))
packages)))))

4
guix/scripts/offload.scm
View file

@ -606,9 +606,7 @@ (define (undecorate pred)
((machine1 slot1)
(match b
((machine2 slot2)
(if (pred machine1 machine2)
(list machine1 slot1)
(list machine2 slot2))))))))
(pred machine1 machine2)))))))
(let loop ((machines+slots
(sort machines+slots

36
guix/scripts/package.scm
View file

@ -47,8 +47,7 @@ (define-module (guix scripts package)
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
#:export (specification->package+output
switch-to-generation
#:export (switch-to-generation
switch-to-previous-generation
roll-back
delete-generation
@ -324,39 +323,6 @@ (define-syntax-rule (leave-on-EPIPE exp ...)
(primitive-_exit 0)
(apply throw args)))))
(define* (specification->package+output spec #:optional (output "out"))
"Return the package and output specified by SPEC, or #f and #f; SPEC may
optionally contain a version number and an output name, as in these examples:
guile
guile-2.0.9
guile:debug
guile-2.0.9:debug
If SPEC does not specify a version number, return the preferred newest
version; if SPEC does not specify an output, return OUTPUT."
(define (ensure-output p sub-drv)
(if (member sub-drv (package-outputs p))
sub-drv
(leave (_ "package `~a' lacks output `~a'~%")
(package-full-name p)
sub-drv)))
(let-values (((name version sub-drv)
(package-specification->name+version+output spec output)))
(match (find-best-packages-by-name name version)
((p)
(values p (ensure-output p sub-drv)))
((p p* ...)
(warning (_ "ambiguous package specification `~a'~%")
spec)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
(values p (ensure-output p sub-drv)))
(()
(leave (_ "~a: package not found~%") spec)))))
(define (upgradeable? name current-version current-path)
"Return #t if there's a version of package NAME newer than CURRENT-VERSION,
or if the newest available version is equal to CURRENT-VERSION but would have

247
guix/scripts/size.scm Normal file
View file

@ -0,0 +1,247 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts size)
#:use-module (guix ui)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (gnu packages)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (profile?
profile-file
profile-self-size
profile-closure-size
store-profile
guix-size))
;; Size profile of a store item.
(define-record-type <profile>
(profile file self-size closure-size)
profile?
(file profile-file) ;store item
(self-size profile-self-size) ;size in bytes
(closure-size profile-closure-size)) ;size of dependencies in bytes
(define (file-size file)
"Return the size of bytes of FILE, entering it if FILE is a directory."
(file-system-fold (const #t)
(lambda (file stat result) ;leaf
(+ (stat:size stat) result))
(lambda (directory stat result) ;down
(+ (stat:size stat) result))
(lambda (directory stat result) ;up
result)
(lambda (file stat result) ;skip
result)
(lambda (file stat errno result)
(format (current-error-port)
"file-size: ~a: ~a~%" file
(strerror errno))
result)
0
file
lstat))
(define substitutable-path-info*
(store-lift substitutable-path-info))
(define (store-item-exists? item)
"Return #t if ITEM is in the store, and protect it from GC. Otherwise
return #f."
(lambda (store)
(add-temp-root store item)
(values (valid-path? store item) store)))
(define (file-size* item)
"Like 'file-size', but resort to information from substitutes if ITEM is not
in the store."
(mlet %store-monad ((exists? (store-item-exists? item)))
(if exists?
(return (file-size item))
(mlet %store-monad ((info (substitutable-path-info* (list item))))
(match info
((info)
;; The nar size is an approximation, but a good one.
(return (substitutable-nar-size info)))
(()
(leave (_ "no available substitute information for '~a'~%")
item)))))))
(define* (display-profile profile #:optional (port (current-output-port)))
"Display PROFILE, a list of PROFILE objects, to PORT."
(define MiB (expt 2 20))
(format port "~64a ~8a ~a\n"
(_ "store item") (_ "total") (_ "self"))
(let ((whole (reduce + 0 (map profile-self-size profile))))
(for-each (match-lambda
(($ <profile> name self total)
(format port "~64a ~6,1f ~6,1f ~5,1f%\n"
name (/ total MiB) (/ self MiB)
(* 100. (/ self whole 1.)))))
(sort profile
(match-lambda*
((($ <profile> _ _ total1) ($ <profile> _ _ total2))
(> total1 total2)))))))
(define display-profile*
(lift display-profile %store-monad))
(define (substitutable-requisites store item)
"Return the list of requisites of ITEM based on information available in
substitutes."
(let loop ((items (list item))
(result '()))
(match items
(()
(delete-duplicates result))
(items
(let ((info (substitutable-path-info store
(delete-duplicates items))))
(loop (remove (lambda (item) ;XXX: complexity
(member item result))
(append-map substitutable-references info))
(append (append-map substitutable-references info)
result)))))))
(define (requisites* item)
"Return as a monadic value the requisites of ITEMS, based either on the
information available in the local store or using information about
substitutes."
(lambda (store)
(guard (c ((nix-protocol-error? c)
(values (substitutable-requisites store item)
store)))
(values (requisites store item) store))))
(define (store-profile item)
"Return as a monadic value a list of <profile> objects representing the
profile of ITEM and its requisites."
(mlet* %store-monad ((refs (>>= (requisites* item)
(lambda (refs)
(return (delete-duplicates
(cons item refs))))))
(sizes (mapm %store-monad
(lambda (item)
(>>= (file-size* item)
(lambda (size)
(return (cons item size)))))
refs)))
(define (dependency-size item)
(mlet %store-monad ((deps (requisites* item)))
(foldm %store-monad
(lambda (item total)
(return (+ (assoc-ref sizes item) total)))
0
(delete-duplicates (cons item deps)))))
(mapm %store-monad
(match-lambda
((item . size)
(mlet %store-monad ((dependencies (dependency-size item)))
(return (profile item size dependencies)))))
sizes)))
(define* (ensure-store-item spec-or-item
#:key dry-run?)
"Return a store file name. If SPEC-OR-ITEM is a store file name, return it
as is. Otherwise, assume SPEC-OR-ITEM is a package output specification such
as \"guile:debug\" or \"gcc-4.8\" and return its store file name."
(with-monad %store-monad
(if (store-path? spec-or-item)
(return spec-or-item)
(let-values (((package output)
(specification->package+output spec-or-item)))
(mlet %store-monad ((drv (package->derivation package)))
;; Note: we don't try building DRV like 'guix archive' does
;; because we don't have to since we can instead rely on
;; substitute meta-data.
(return (derivation->output-path drv output)))))))
;;;
;;; Options.
;;;
(define (show-help)
(display (_ "Usage: guix size [OPTION]... PACKAGE
Report the size of PACKAGE and its dependencies.\n"))
(display (_ "
-s, --system=SYSTEM consider packages for SYSTEM--e.g., \"i686-linux\""))
(newline)
(display (_ "
-h, --help display this help and exit"))
(display (_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(define %options
;; Specifications of the command-line options.
(list (option '(#\s "system") #t #f
(lambda (opt name arg result)
(alist-cons 'system arg
(alist-delete 'system result eq?))))
(option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix size")))))
(define %default-options
`((system . ,(%current-system))))
;;;
;;; Entry point.
;;;
(define (guix-size . args)
(with-error-handling
(let* ((opts (parse-command-line args %options (list %default-options)))
(files (filter-map (match-lambda
(('argument . file) file)
(_ #f))
opts))
(system (assoc-ref opts 'system))
(dry-run? (assoc-ref opts 'dry-run?)))
(match files
(()
(leave (_ "missing store item argument\n")))
((file)
(with-store store
(run-with-store store
(mlet* %store-monad ((item (ensure-store-item file))
(profile (store-profile item)))
(display-profile* profile))
#:system system)))
((files ...)
(leave (_ "too many arguments\n")))))))

2
po/guix/POTFILES.in
View file

@ -16,6 +16,8 @@ guix/scripts/authenticate.scm
guix/scripts/system.scm
guix/scripts/lint.scm
guix/scripts/publish.scm
guix/scripts/edit.scm
guix/scripts/size.scm
guix/gnu-maintenance.scm
guix/ui.scm
guix/http-client.scm

87
tests/size.scm Normal file
View file

@ -0,0 +1,87 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 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 (test-size)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix gexp)
#:use-module (guix tests)
#:use-module (guix scripts size)
#:use-module (gnu packages bootstrap)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64))
(define %store
(open-connection-for-tests))
(define-syntax-rule (test-assertm name exp)
(test-assert name
(run-with-store %store exp
#:guile-for-build (%guile-for-build))))
(test-begin "size")
(test-assertm "store-profile"
(mlet* %store-monad ((file1 (gexp->derivation "file1"
#~(symlink #$%bootstrap-guile
#$output)))
(file2 (text-file* "file2"
"the file => " file1)))
(define (matching-profile item)
(lambda (profile)
(string=? item (profile-file profile))))
(mbegin %store-monad
(built-derivations (list file2))
(mlet %store-monad ((profiles (store-profile
(derivation->output-path file2)))
(guile (package->derivation %bootstrap-guile)))
(define (lookup-profile drv)
(find (matching-profile (derivation->output-path drv))
profiles))
(letrec-syntax ((match* (syntax-rules (=>)
((_ ((drv => profile) rest ...) body)
(match (lookup-profile drv)
((? profile? profile)
(match* (rest ...) body))))
((_ () body)
body))))
;; Make sure we get all three profiles with sensible values.
(return (and (= (length profiles) 3)
(match* ((file1 => profile1)
(file2 => profile2)
(guile => profile3))
(and (> (profile-closure-size profile2) 0)
(= (profile-closure-size profile2)
(+ (profile-self-size profile1)
(profile-self-size profile2)
(profile-self-size profile3))))))))))))
(test-end "size")
(exit (= (test-runner-fail-count (test-runner-current)) 0))
;;; Local Variables:
;;; eval: (put 'match* 'scheme-indent-function 1)
;;; End: