diff --git a/Makefile.am b/Makefile.am index 189b637be3..4236de4fce 100644 --- a/Makefile.am +++ b/Makefile.am @@ -130,6 +130,7 @@ EXTRA_DIST = \ .dir-locals.el \ build-aux/hydra/gnu-system.scm \ build-aux/download.scm \ + build-aux/list-packages.scm \ build-aux/sync-synopses.scm \ srfi/srfi-64.scm \ srfi/srfi-64.upstream.scm \ 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 +;;; +;;; 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 . + +(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 + + +GNU Guix - GNU Distribution - GNU Project + + +") + (display (sxml->xml (packages->sxml packages))) + (format #t " +
+ +

Please send general FSF & GNU inquiries to +<gnu@gnu.org>. +There are also other ways to contact +the FSF. Broken links and other corrections or suggestions can be sent +to <bug-guix@gnu.org>.

+ +

Copyright © 2013 Free Software Foundation, Inc.

+ +

This page is licensed under a Creative +Commons Attribution-NoDerivs 3.0 United States License.

+ +

Updated: + +$Date$ + +

+
+ + + +")) + ) + +;;; list-packages.scm ends here