build-aux/list-packages.scm

   1 #!/bin/sh
   2 exec guile -l "$0"                              \
   3   -c '(apply (@ (list-packages) list-packages)
   4              (cdr (command-line)))'
   5 !#
   6 ;;; GNU Guix --- Functional package management for GNU
   7 ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (list-packages)
  25   #:use-module (guix utils)
  26   #:use-module (guix packages)
  27   #:use-module (guix licenses)
  28   #:use-module (guix gnu-maintenance)
  29   #:use-module (gnu packages)
  30   #:use-module (sxml simple)
  31   #:use-module (web uri)
  32   #:use-module (ice-9 match)
  33   #:use-module (srfi srfi-1)
  34   #:export (list-packages))
  35
  36 ;;; Commentary:
  37 ;;;
  38 ;;; Emit an HTML representation of the packages available in GNU Guix.
  39 ;;;
  40 ;;; Code:
  41
  42 (define lookup-gnu-package
  43   (let ((gnu (official-gnu-packages)))
  44     (lambda (name)
  45       "Return the package description for GNU package NAME, or #f."
  46       (find (lambda (package)
  47               (equal? (gnu-package-name package) name))
  48             gnu))))
  49
  50 (define (package->sxml package)
  51   "Return HTML-as-SXML representing PACKAGE."
  52   (define (source-url package)
  53     (let ((loc (package-location package)))
  54       (and loc
  55            (string-append "http://git.savannah.gnu.org/cgit/guix.git/tree/"
  56                           (location-file loc) "#n"
  57                           (number->string (location-line loc))))))
  58
  59   (define (license package)
  60     (define ->sxml
  61       (match-lambda
  62        ((lst ...)
  63         `(div ,(map ->sxml lst)))
  64        ((? license? license)
  65         (let ((uri (license-uri license)))
  66           (case (and=> (and uri (string->uri uri)) uri-scheme)
  67             ((http https)
  68              `(div (a (@ (href ,uri))
  69                       ,(license-name license))))
  70             (else
  71              `(div ,(license-name license) " ("
  72                    ,(license-comment license) ")")))))
  73        (#f "")))
  74
  75     (->sxml (package-license package)))
  76
  77   (define (status package)
  78     (define (url system)
  79       `(a (@ (href ,(string-append "http://hydra.gnu.org/job/gnu/master/"
  80                                    (package-full-name package) "."
  81                                    system)))
  82           ,system))
  83
  84     `(div "status: "
  85           ,(url "x86_64-linux") " "
  86           ,(url "i686-linux")))
  87
  88   (define (package-logo name)
  89     (and=> (lookup-gnu-package name)
  90            gnu-package-logo))
  91
  92   (let ((description-id (symbol->string
  93                          (gensym (package-name package)))))
  94    `(tr (td ,(if (gnu-package? package)
  95                  `(img (@ (src "/graphics/gnu-head-mini.png")))
  96                  ""))
  97         (td (a (@ (href ,(source-url package)))
  98                ,(package-name package) " "
  99                ,(package-version package)))
 100         (td (@ (colspan "2") (height "0"))
 101             (a (@ (href "javascript:void(0)")
 102                   (title "show/hide package description")
 103                   (onClick ,(format #f "javascript:show_hide('~a')"
 104                                     description-id)))
 105                ,(package-synopsis package))
 106             (div (@ (id ,description-id)
 107                     (style "position: relative; display: none;"))
 108                  ,(match (package-logo (package-name package))
 109                     ((? string? url)
 110                      `(img (@ (src ,url)
 111                               (height "35em")
 112                               (style "float: left; padding-right: 1em;"))))
 113                     (_ #f))
 114                  (p ,(package-description package))
 115                  ,(license package)
 116                  (a (@ (href ,(package-home-page package)))
 117                     ,(package-home-page package))
 118                  ,(status package))))))
 119
 120 (define (packages->sxml packages)
 121   "Return an HTML page as SXML describing PACKAGES."
 122   `(div
 123     (h2 "GNU Guix Package List")
 124     (div (@ (style "margin-bottom: 5em;"))
 125          (div
 126           (img (@ (src "graphics/guix-logo.small.png")
 127                   (alt "GNU Guix and the GNU System")
 128                   (height "83em"))))
 129          "This web page lists the packages currently provided by the "
 130          (a (@ (href "manual/guix.html#GNU-Distribution"))
 131             "GNU system distribution")
 132          " of "
 133          (a (@ (href "/software/guix/guix.html")) "GNU Guix") ".  "
 134          "Our " (a (@ (href "http://hydra.gnu.org/jobset/gnu/master"))
 135                    "continuous integration system")
 136          " shows their current build status.")
 137     (table (@ (style "border: none;"))
 138            ,@(map package->sxml packages))))
 139
 140 \f
 141 (define (list-packages . args)
 142   "Return an HTML page listing all the packages found in the GNU distribution,
 143 with gnu.org server-side include and all that."
 144   ;; Don't attempt to translate descriptions.
 145   (setlocale LC_ALL "C")
 146
 147   ;; Output the page as UTF-8 since that's what the gnu.org server-side
 148   ;; headers claim.
 149   (set-port-encoding! (current-output-port) "UTF-8")
 150
 151   (let ((packages (sort (fold-packages cons '())
 152                         (lambda (p1 p2)
 153                           (string<? (package-name p1) (package-name p2))))))
 154    (format #t "<!--#include virtual=\"/server/html5-header.html\" -->
 155 <!-- Parent-Version: 1.70 $ -->
 156
 157 <title>GNU Guix - GNU Distribution - GNU Project</title>
 158 <!--#include virtual=\"/server/banner.html\" -->
 159
 160 <script language=\"javascript\" type=\"text/javascript\">
 161 // license: CC0
 162 function show_hide(idThing)
 163 {
 164   var thing = document.getElementById(idThing);
 165   if (thing) {
 166     if (thing.style.display == \"none\") {
 167       thing.style.display = \"\";
 168     } else {
 169       thing.style.display = \"none\";
 170     }
 171   }
 172 }
 173 </script>")
 174    (display (sxml->xml (packages->sxml packages)))
 175    (format #t "<!--#include virtual=\"/server/footer.html\" -->
 176 <div id=\"footer\">
 177
 178 <p>Please send general FSF &amp; GNU inquiries to
 179 <a href=\"mailto:gnu@gnu.org\">&lt;gnu@gnu.org&gt;</a>.
 180 There are also <a href=\"/contact/\">other ways to contact</a>
 181 the FSF.  Broken links and other corrections or suggestions can be sent
 182 to <a href=\"mailto:bug-guix@gnu.org\">&lt;bug-guix@gnu.org&gt;</a>.</p>
 183
 184 <p>Copyright &copy; 2013 Free Software Foundation, Inc.</p>
 185
 186 <p>This page is licensed under a <a rel=\"license\"
 187 href=\"http://creativecommons.org/licenses/by-nd/3.0/us/\">Creative
 188 Commons Attribution-NoDerivs 3.0 United States License</a>.</p>
 189
 190 <p>Updated:
 191 <!-- timestamp start -->
 192 $Date$
 193 <!-- timestamp end -->
 194 </p>
 195 </div>
 196 </div>
 197 </body>
 198 </html>
 199 "))
 200   )
 201
 202 ;;; list-packages.scm ends here