aboutsummaryrefslogtreecommitdiff
path: root/build-aux/list-packages.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-07-10 00:27:53 +0200
committerLudovic Courtès <ludo@gnu.org>2013-07-10 00:27:53 +0200
commitb592f7113edf6eccef8dcd5926616e09621e08c8 (patch)
treec6ee936530dd52b7f65760c82961c052b4172034 /build-aux/list-packages.scm
parentc769406010156190c76c435c90d5f08ae56c2ca4 (diff)
downloadguix-b592f7113edf6eccef8dcd5926616e09621e08c8.tar
guix-b592f7113edf6eccef8dcd5926616e09621e08c8.tar.gz
Add `build-aux/list-packages.scm'.
* build-aux/list-packages.scm: New file. * Makefile.am (EXTRA_DIST): Add it.
Diffstat (limited to 'build-aux/list-packages.scm')
-rwxr-xr-xbuild-aux/list-packages.scm161
1 files changed, 161 insertions, 0 deletions
diff --git a/build-aux/list-packages.scm b/build-aux/list-packages.scm
new file mode 100755
index 0000000000..cdefa1ba97
--- /dev/null
+++ b/build-aux/list-packages.scm
@@ -0,0 +1,161 @@
+#!/bin/sh
+exec guile -l "$0" \
+ -c '(apply (@ (list-packages) list-packages)
+ (cdr (command-line)))'
+!#
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 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 (list-packages)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix licenses)
+ #:use-module (guix gnu-maintenance)
+ #:use-module (gnu packages)
+ #:use-module (sxml simple)
+ #:use-module (web uri)
+ #:use-module (ice-9 match)
+ #:export (list-packages))
+
+;;; Commentary:
+;;;
+;;; Emit an HTML representation of the packages available in GNU Guix.
+;;;
+;;; Code:
+
+(define (package->sxml package)
+ "Return HTML-as-SXML representing PACKAGE."
+ (define (source-url package)
+ (let ((loc (package-location package)))
+ (and loc
+ (string-append "http://git.savannah.gnu.org/cgit/guix.git/tree/"
+ (location-file loc) "#n"
+ (number->string (location-line 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))
+ ,(license-name license))))
+ (else
+ `(div ,(license-name license) " ("
+ ,(license-comment license) ")")))))
+ (#f "")))
+
+ (->sxml (package-license package)))
+
+ (let ((description-id (symbol->string
+ (gensym (package-name package)))))
+ `(tr (td ,(if (gnu-package? package)
+ `(img (@ (src "/graphics/gnu-head-mini.png")))
+ ""))
+ (td (a (@ (href ,(source-url package)))
+ ,(package-name package) " "
+ ,(package-version package)))
+ (td (@ (colspan "2") (height "0"))
+ (a (@ (href "javascript:void(0)")
+ (title "show/hide package description")
+ (onClick ,(format #f "javascript:show_hide('~a')"
+ description-id)))
+ ,(package-synopsis package))
+ (div (@ (id ,description-id)
+ (style "position: relative; display: none;"))
+ (p ,(package-description package))
+ ,(license package)
+ (a (@ (href ,(package-home-page package)))
+ ,(package-home-page package)))))))
+
+(define (packages->sxml packages)
+ "Return an HTML page as SXML describing PACKAGES."
+ `(div
+ (h2 "GNU Guix Package List")
+ (div (@ (style "margin-bottom: 5em;"))
+ (div
+ (img (@ (src "graphics/guix-logo.small.png")
+ (alt "GNU Guix and the GNU System")
+ (height "83em"))))
+ "This web page lists the packages currently provided by the "
+ (a (@ (href "manual/guix.html#GNU-Distribution"))
+ "GNU system distribution")
+ " of "
+ (a (@ (href "/software/guix/guix.html")) "GNU Guix") ".")
+ (table (@ (style "border: none;"))
+ ,@(map package->sxml packages))))
+
+
+(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."
+ (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>
+<!--#include virtual=\"/server/banner.html\" -->
+
+<script language=\"javascript\" type=\"text/javascript\">
+// license: CC0
+function show_hide(idThing)
+{
+ var thing = document.getElementById(idThing);
+ if (thing) {
+ if (thing.style.display == \"none\") {
+ thing.style.display = \"\";
+ } else {
+ thing.style.display = \"none\";
+ }
+ }
+}
+</script>")
+ (display (sxml->xml (packages->sxml packages)))
+ (format #t "<!--#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