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, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   8 ;;; Copyright © 2013 Alex Sassmannshausen <alex.sassmannshausen@gmail.com>
   9 ;;;
  10 ;;; This file is part of GNU Guix.
  11 ;;;
  12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  13 ;;; under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 3 of the License, or (at
  15 ;;; your option) any later version.
  16 ;;;
  17 ;;; GNU Guix is distributed in the hope that it will be useful, but
  18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 (define-module (list-packages)
  26   #:use-module (guix utils)
  27   #:use-module (guix packages)
  28   #:use-module (guix licenses)
  29   #:use-module (guix gnu-maintenance)
  30   #:use-module ((guix download) #:select (%mirrors))
  31   #:use-module ((guix build download) #:select (maybe-expand-mirrors))
  32   #:use-module (gnu packages)
  33   #:use-module (sxml simple)
  34   #:use-module (sxml fold)
  35   #:use-module (web uri)
  36   #:use-module (ice-9 match)
  37   #:use-module (srfi srfi-1)
  38   #:export (list-packages))
  39
  40 ;;; Commentary:
  41 ;;;
  42 ;;; Emit an HTML representation of the packages available in GNU Guix.
  43 ;;;
  44 ;;; Code:
  45
  46 (define lookup-gnu-package
  47   (let ((gnu (official-gnu-packages)))
  48     (lambda (name)
  49       "Return the package description for GNU package NAME, or #f."
  50       (find (lambda (package)
  51               (equal? (gnu-package-name package) name))
  52             gnu))))
  53
  54 (define (list-join lst item)
  55   "Join the items in LST by inserting ITEM between each pair of elements."
  56   (let loop ((lst    lst)
  57              (result '()))
  58     (match lst
  59       (()
  60        (match (reverse result)
  61          (()
  62           '())
  63          ((_ rest ...)
  64           rest)))
  65       ((head tail ...)
  66        (loop tail
  67              (cons* head item result))))))
  68
  69 (define (package->sxml package previous description-ids remaining)
  70   "Return 3 values: the HTML-as-SXML for PACKAGE added to all previously
  71 collected package output in PREVIOUS, a list of DESCRIPTION-IDS and the number
  72 of packages still to be processed in REMAINING.  Also Introduces a call to the
  73 JavaScript prep_pkg_descs function as part of the output of PACKAGE, every
  74 time the length of DESCRIPTION-IDS, increasing, is 15 or when REMAINING,
  75 decreasing, is 1."
  76   (define (location-url loc)
  77     (string-append "http://git.savannah.gnu.org/cgit/guix.git/tree/"
  78                    (location-file loc) "#n"
  79                    (number->string (location-line loc))))
  80
  81   (define (source-url package)
  82     (let ((loc (package-location package)))
  83       (and loc (location-url loc))))
  84
  85   (define (license package)
  86     (define ->sxml
  87       (match-lambda
  88        ((lst ...)
  89         `(div ,(map ->sxml lst)))
  90        ((? license? license)
  91         (let ((uri (license-uri license)))
  92           (case (and=> (and uri (string->uri uri)) uri-scheme)
  93             ((http https)
  94              `(div (a (@ (href ,uri)
  95                          (title "Link to the full license"))
  96                       ,(license-name license))))
  97             (else
  98              `(div ,(license-name license) " ("
  99                    ,(license-comment license) ")")))))
 100        (#f "")))
 101
 102     (->sxml (package-license package)))
 103
 104   (define (patches package)
 105     (define patch-url
 106       (match-lambda
 107        ((? string? patch)
 108         (string-append
 109          "http://git.savannah.gnu.org/cgit/guix.git/tree/gnu/packages/patches/"
 110          (basename patch)))
 111        ((? origin? patch)
 112         (uri->string
 113          (first (maybe-expand-mirrors (string->uri
 114                                        (match (origin-uri patch)
 115                                          ((? string? uri) uri)
 116                                          ((head . tail) head)))
 117                                       %mirrors))))))
 118
 119     (define patch-name
 120       (match-lambda
 121        ((? string? patch)
 122         (basename patch))
 123        ((? origin? patch)
 124         (match (origin-uri patch)
 125           ((? string? uri) (basename uri))
 126           ((head . tail) (basename head))))))
 127
 128     (define (snippet-link snippet)
 129       (let ((loc (or (package-field-location package 'source)
 130                      (package-location package))))
 131         `(a (@ (href ,(location-url loc))
 132                (title "Link to patch snippet"))
 133             "snippet")))
 134
 135     (and (origin? (package-source package))
 136          (let ((patches (origin-patches (package-source package)))
 137                (snippet (origin-snippet (package-source package))))
 138            (and (or (pair? patches) snippet)
 139                 `(div "patches: "
 140                       ,(let loop ((patches patches)
 141                                   (number  1)
 142                                   (links   '()))
 143                          (match patches
 144                            (()
 145                             (let* ((additional (and snippet
 146                                                     (snippet-link snippet)))
 147                                    (links      (if additional
 148                                                    (cons additional links)
 149                                                    links)))
 150                               (list-join (reverse links) ", ")))
 151                            ((patch rest ...)
 152                             (loop rest
 153                                   (+ 1 number)
 154                                   (cons `(a (@ (href ,(patch-url patch))
 155                                                (title ,(string-append
 156                                                         "Link to "
 157                                                         (patch-name patch))))
 158                                             ,(number->string number))
 159                                         links))))))))))
 160
 161   (define (status package)
 162     (define (url system)
 163       `(a (@ (href ,(string-append "http://hydra.gnu.org/job/gnu/master/"
 164                                    (package-full-name package) "."
 165                                    system))
 166              (title "View the status of this architecture's build at Hydra"))
 167           ,system))
 168
 169     `(div "status: "
 170           ,(list-join (map url (package-transitive-supported-systems package))
 171                       " ")))
 172
 173   (define (package-logo name)
 174     (and=> (lookup-gnu-package name)
 175            gnu-package-logo))
 176
 177   (define (insert-tr description-id js?)
 178     (define (insert-js-call description-ids)
 179       "Return an sxml call to prep_pkg_descs, with up to 15 elements of
 180 description-ids as formal parameters."
 181       `(script (@ (type "text/javascript"))
 182                ,(format #f "prep_pkg_descs(~a)"
 183                         (string-append "'"
 184                                        (string-join description-ids "', '")
 185                                        "'"))))
 186
 187     (let ((description-ids (cons description-id description-ids)))
 188       `(tr (td ,(if (gnu-package? package)
 189                     `(img (@ (src "/graphics/gnu-head-mini.png")
 190                              (alt "Part of GNU")
 191                              (title "Part of GNU")))
 192                     ""))
 193            (td (a (@ (href ,(source-url package))
 194                      (title "Link to the Guix package source code"))
 195                   ,(package-name package) " "
 196                   ,(package-version package)))
 197            (td (span ,(package-synopsis package))
 198                (div (@ (id ,description-id))
 199                     ,(match (package-logo (package-name package))
 200                        ((? string? url)
 201                         `(img (@ (src ,url)
 202                                  (height "35")
 203                                  (class "package-logo")
 204                                  (alt ("Logo of " ,(package-name package))))))
 205                        (_ #f))
 206                     (p ,(package-description package))
 207                     ,(license package)
 208                     (a (@ (href ,(package-home-page package))
 209                           (title "Link to the package's website"))
 210                        ,(package-home-page package))
 211                     ,(status package)
 212                     ,(patches package)
 213                     ,(if js?
 214                          (insert-js-call description-ids)
 215                          ""))))))
 216
 217   (let ((description-id (symbol->string
 218                          (gensym (package-name package)))))
 219     (cond ((= remaining 1)              ; Last package in packages
 220            (values
 221             (reverse                              ; Fold has reversed packages
 222              (cons (insert-tr description-id 'js) ; Prefix final sxml
 223                    previous))
 224             '()                            ; No more work to do
 225             0))                            ; End of the line
 226           ((= (length description-ids) 15) ; Time for a JS call
 227            (values
 228             (cons (insert-tr description-id 'js)
 229                   previous)    ; Prefix new sxml
 230             '()                ; Reset description-ids
 231             (1- remaining)))   ; Reduce remaining
 232           (else                ; Insert another row, and build description-ids
 233            (values
 234             (cons (insert-tr description-id #f)
 235                   previous)                       ; Prefix new sxml
 236             (cons description-id description-ids) ; Update description-ids
 237             (1- remaining))))))                   ; Reduce remaining
 238
 239 (define (packages->sxml packages)
 240   "Return an HTML page as SXML describing PACKAGES."
 241   `(div
 242     (h2 "GNU Guix Package List")
 243     (div (@ (id "intro"))
 244          (div
 245           (img (@ (src "graphics/GuixSD-V.png")
 246                   (alt "Guix System Distribution")
 247                   (height "83"))))
 248          (p "This web page lists the packages currently provided by the "
 249             (a (@ (href "manual/guix.html#GNU-Distribution"))
 250                "Guix System Distribution")
 251             ".  "
 252             "Our " (a (@ (href "http://hydra.gnu.org/jobset/gnu/master"))
 253                       "continuous integration system")
 254             " shows their current build status."))
 255     (table (@ (id "packages"))
 256            (tr (th "GNU?")
 257                (th "Package version")
 258                (th "Package details"))
 259            ,@(fold-values package->sxml packages '() '() (length packages)))
 260     (a (@ (href "#intro")
 261           (title "Back to top.")
 262           (id "top"))
 263        "^")))
 264
 265 \f
 266 (define (insert-css)
 267   "Return the CSS for the list-packages page."
 268   (format #t
 269 "<style>
 270 /* license: CC0 */
 271 a {
 272     transition: all 0.3s;
 273 }
 274 div#intro {
 275     margin-bottom: 2em;
 276 }
 277 div#intro div, div#intro p {
 278     padding:0.5em;
 279 }
 280 div#intro div {
 281     float:left;
 282 }
 283 div#intro img {
 284     float:left;
 285     padding:0.75em;
 286 }
 287 table#packages, table#packages tr, table#packages tbody, table#packages td, table#packages th {
 288     border: 0px solid black;
 289     clear: both;
 290 }
 291 table#packages tr:nth-child(even) {
 292     background-color: #FFF;
 293 }
 294 table#packages tr:nth-child(odd) {
 295     background-color: #EEE;
 296 }
 297 table#packages tr:hover, table#packages tr:focus, table#packages tr:active {
 298     background-color: #DDD;
 299 }
 300 table#packages tr:first-child, table#packages tr:first-child:hover, table#packages tr:first-child:focus, table#packages tr:first-child:active {
 301     background-color: #333;
 302     color: #fff;
 303 }
 304 table#packages td {
 305     margin:0px;
 306     padding:0.2em 0.5em;
 307 }
 308 table#packages td:first-child {
 309     width:10%;
 310     text-align:center;
 311 }
 312 table#packages td:nth-child(2) {
 313     width:30%;
 314 }
 315 table#packages td:last-child {
 316     width:60%;
 317 }
 318 img.package-logo {
 319     float: left;
 320     padding: 0.75em;
 321 }
 322 table#packages span {
 323     font-weight: 700;
 324 }
 325 table#packages span a {
 326     float: right;
 327     font-weight: 500;
 328 }
 329 a#top {
 330     position:fixed;
 331     right:10px;
 332     bottom:10px;
 333     font-size:150%;
 334     background-color:#EEE;
 335     padding:10px 7.5px 0 7.5px;
 336     text-decoration:none;
 337     color:#000;
 338     border-radius:5px;
 339 }
 340 a#top:hover, a#top:focus {
 341     background-color:#333;
 342     color:#fff;
 343 }
 344 </style>"))
 345
 346 (define (insert-js)
 347   "Return the JavaScript for the list-packages page."
 348   (format #t
 349 "<script type=\"text/javascript\">
 350 // license: CC0
 351 function show_hide(idThing)
 352 {
 353   if(document.getElementById && document.createTextNode) {
 354     var thing = document.getElementById(idThing);
 355     /* Used to change the link text, depending on whether description is
 356        collapsed or expanded */
 357     var thingLink = thing.previousSibling.lastChild.firstChild;
 358     if (thing) {
 359       if (thing.style.display == \"none\") {
 360         thing.style.display = \"\";
 361         thingLink.data = 'Collapse';
 362       } else {
 363         thing.style.display = \"none\";
 364         thingLink.data = 'Expand';
 365       }
 366     }
 367   }
 368 }
 369 /* Add controllers used for collapse/expansion of package descriptions */
 370 function prep(idThing)
 371 {
 372   var tdThing = document.getElementById(idThing).parentNode;
 373   if (tdThing) {
 374     var aThing = tdThing.firstChild.appendChild(document.createElement('a'));
 375     aThing.setAttribute('href', 'javascript:void(0)');
 376     aThing.setAttribute('title', 'show/hide package description');
 377     aThing.appendChild(document.createTextNode('Expand'));
 378     aThing.onclick=function(){show_hide(idThing);};
 379     /* aThing.onkeypress=function(){show_hide(idThing);}; */
 380   }
 381 }
 382 /* Take n element IDs, prepare them for javascript enhanced
 383    display and hide the IDs by default. */
 384 function prep_pkg_descs()
 385 {
 386   if(document.getElementById && document.createTextNode) {
 387     for(var i=0; i<arguments.length; i++) {
 388       prep(arguments[i])
 389       show_hide(arguments[i]);
 390     }
 391   }
 392 }
 393 </script>"))
 394
 395 \f
 396 (define (list-packages . args)
 397   "Return an HTML page listing all the packages found in the GNU distribution,
 398 with gnu.org server-side include and all that."
 399   ;; Don't attempt to translate descriptions.
 400   (setlocale LC_ALL "C")
 401
 402   ;; Output the page as UTF-8 since that's what the gnu.org server-side
 403   ;; headers claim.
 404   (set-port-encoding! (current-output-port) "UTF-8")
 405
 406   (let ((packages (sort (fold-packages cons '())
 407                         (lambda (p1 p2)
 408                           (string<? (package-name p1) (package-name p2))))))
 409    (format #t "<!--#include virtual=\"/server/html5-header.html\" -->
 410 <!-- Parent-Version: 1.70 $ -->
 411 <title>GNU Guix - GNU Distribution - GNU Project</title>
 412 ")
 413    (insert-css)
 414    (insert-js)
 415    (format #t "<!--#include virtual=\"/server/banner.html\" -->")
 416
 417    (sxml->xml (packages->sxml packages))
 418    (format #t "</div>
 419 <!--#include virtual=\"/server/footer.html\" -->
 420 <div id=\"footer\">
 421
 422 <p>Please send general FSF &amp; GNU inquiries to
 423 <a href=\"mailto:gnu@gnu.org\">&lt;gnu@gnu.org&gt;</a>.
 424 There are also <a href=\"/contact/\">other ways to contact</a>
 425 the FSF.  Broken links and other corrections or suggestions can be sent
 426 to <a href=\"mailto:bug-guix@gnu.org\">&lt;bug-guix@gnu.org&gt;</a>.</p>
 427
 428 <p>Copyright &copy; 2013 Free Software Foundation, Inc.</p>
 429
 430 <p>This page is licensed under a <a rel=\"license\"
 431 href=\"http://creativecommons.org/licenses/by-nd/3.0/us/\">Creative
 432 Commons Attribution-NoDerivs 3.0 United States License</a>.</p>
 433
 434 <p>Updated:
 435 <!-- timestamp start -->
 436 $Date$
 437 <!-- timestamp end -->
 438 </p>
 439 </div>
 440 </div>
 441 </body>
 442 </html>
 443 "))
 444   )
 445
 446 ;;; list-packages.scm ends here