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
 171                            (lset-intersection
 172                             string=?
 173                             %hydra-supported-systems
 174                             (package-transitive-supported-systems package)))
 175                       " ")))
 176
 177   (define (package-logo name)
 178     (and=> (lookup-gnu-package name)
 179            gnu-package-logo))
 180
 181   (define (insert-tr description-id js?)
 182     (define (insert-js-call description-ids)
 183       "Return an sxml call to prep_pkg_descs, with up to 15 elements of
 184 description-ids as formal parameters."
 185       `(script (@ (type "text/javascript"))
 186                ,(format #f "prep_pkg_descs(~a)"
 187                         (string-append "'"
 188                                        (string-join description-ids "', '")
 189                                        "'"))))
 190
 191     (let ((description-ids (cons description-id description-ids)))
 192       `(tr (td ,(if (gnu-package? package)
 193                     `(img (@ (src "/graphics/gnu-head-mini.png")
 194                              (alt "Part of GNU")
 195                              (title "Part of GNU")))
 196                     ""))
 197            (td (a (@ (href ,(source-url package))
 198                      (title "Link to the Guix package source code"))
 199                   ,(package-name package) " "
 200                   ,(package-version package)))
 201            (td (span ,(package-synopsis package))
 202                (div (@ (id ,description-id))
 203                     ,(match (package-logo (package-name package))
 204                        ((? string? url)
 205                         `(img (@ (src ,url)
 206                                  (height "35")
 207                                  (class "package-logo")
 208                                  (alt ("Logo of " ,(package-name package))))))
 209                        (_ #f))
 210                     (p ,(package-description package))
 211                     ,(license package)
 212                     (a (@ (href ,(package-home-page package))
 213                           (title "Link to the package's website"))
 214                        ,(package-home-page package))
 215                     ,(status package)
 216                     ,(patches package)
 217                     ,(if js?
 218                          (insert-js-call description-ids)
 219                          ""))))))
 220
 221   (let ((description-id (symbol->string
 222                          (gensym (package-name package)))))
 223     (cond ((= remaining 1)              ; Last package in packages
 224            (values
 225             (reverse                              ; Fold has reversed packages
 226              (cons (insert-tr description-id 'js) ; Prefix final sxml
 227                    previous))
 228             '()                            ; No more work to do
 229             0))                            ; End of the line
 230           ((= (length description-ids) 15) ; Time for a JS call
 231            (values
 232             (cons (insert-tr description-id 'js)
 233                   previous)    ; Prefix new sxml
 234             '()                ; Reset description-ids
 235             (1- remaining)))   ; Reduce remaining
 236           (else                ; Insert another row, and build description-ids
 237            (values
 238             (cons (insert-tr description-id #f)
 239                   previous)                       ; Prefix new sxml
 240             (cons description-id description-ids) ; Update description-ids
 241             (1- remaining))))))                   ; Reduce remaining
 242
 243 (define (packages->sxml packages)
 244   "Return an HTML page as SXML describing PACKAGES."
 245   `(div
 246     (h2 "GNU Guix Package List")
 247     (div (@ (id "intro"))
 248          (div
 249           (img (@ (src "graphics/GuixSD-V.png")
 250                   (alt "Guix System Distribution")
 251                   (height "83"))))
 252          (p "This web page lists the packages currently provided by the "
 253             (a (@ (href "manual/guix.html#GNU-Distribution"))
 254                "Guix System Distribution")
 255             ".  "
 256             "Our " (a (@ (href "http://hydra.gnu.org/jobset/gnu/master"))
 257                       "continuous integration system")
 258             " shows their current build status."))
 259     (table (@ (id "packages"))
 260            (tr (th "GNU?")
 261                (th "Package version")
 262                (th "Package details"))
 263            ,@(fold-values package->sxml packages '() '() (length packages)))
 264     (a (@ (href "#intro")
 265           (title "Back to top.")
 266           (id "top"))
 267        "^")))
 268
 269 \f
 270 (define (insert-css)
 271   "Return the CSS for the list-packages page."
 272   (format #t
 273 "<style>
 274 /* license: CC0 */
 275 a {
 276     transition: all 0.3s;
 277 }
 278 div#intro {
 279     margin-bottom: 2em;
 280 }
 281 div#intro div, div#intro p {
 282     padding:0.5em;
 283 }
 284 div#intro div {
 285     float:left;
 286 }
 287 div#intro img {
 288     float:left;
 289     padding:0.75em;
 290 }
 291 table#packages, table#packages tr, table#packages tbody, table#packages td, table#packages th {
 292     border: 0px solid black;
 293     clear: both;
 294 }
 295 table#packages tr:nth-child(even) {
 296     background-color: #FFF;
 297 }
 298 table#packages tr:nth-child(odd) {
 299     background-color: #EEE;
 300 }
 301 table#packages tr:hover, table#packages tr:focus, table#packages tr:active {
 302     background-color: #DDD;
 303 }
 304 table#packages tr:first-child, table#packages tr:first-child:hover, table#packages tr:first-child:focus, table#packages tr:first-child:active {
 305     background-color: #333;
 306     color: #fff;
 307 }
 308 table#packages td {
 309     margin:0px;
 310     padding:0.2em 0.5em;
 311 }
 312 table#packages td:first-child {
 313     width:10%;
 314     text-align:center;
 315 }
 316 table#packages td:nth-child(2) {
 317     width:30%;
 318 }
 319 table#packages td:last-child {
 320     width:60%;
 321 }
 322 img.package-logo {
 323     float: left;
 324     padding: 0.75em;
 325 }
 326 table#packages span {
 327     font-weight: 700;
 328 }
 329 table#packages span a {
 330     float: right;
 331     font-weight: 500;
 332 }
 333 a#top {
 334     position:fixed;
 335     right:10px;
 336     bottom:10px;
 337     font-size:150%;
 338     background-color:#EEE;
 339     padding:10px 7.5px 0 7.5px;
 340     text-decoration:none;
 341     color:#000;
 342     border-radius:5px;
 343 }
 344 a#top:hover, a#top:focus {
 345     background-color:#333;
 346     color:#fff;
 347 }
 348 </style>"))
 349
 350 (define (insert-js)
 351   "Return the JavaScript for the list-packages page."
 352   (format #t
 353 "<script type=\"text/javascript\">
 354 // license: CC0
 355 function show_hide(idThing)
 356 {
 357   if(document.getElementById && document.createTextNode) {
 358     var thing = document.getElementById(idThing);
 359     /* Used to change the link text, depending on whether description is
 360        collapsed or expanded */
 361     var thingLink = thing.previousSibling.lastChild.firstChild;
 362     if (thing) {
 363       if (thing.style.display == \"none\") {
 364         thing.style.display = \"\";
 365         thingLink.data = 'Collapse';
 366       } else {
 367         thing.style.display = \"none\";
 368         thingLink.data = 'Expand';
 369       }
 370     }
 371   }
 372 }
 373 /* Add controllers used for collapse/expansion of package descriptions */
 374 function prep(idThing)
 375 {
 376   var tdThing = document.getElementById(idThing).parentNode;
 377   if (tdThing) {
 378     var aThing = tdThing.firstChild.appendChild(document.createElement('a'));
 379     aThing.setAttribute('href', 'javascript:void(0)');
 380     aThing.setAttribute('title', 'show/hide package description');
 381     aThing.appendChild(document.createTextNode('Expand'));
 382     aThing.onclick=function(){show_hide(idThing);};
 383     /* aThing.onkeypress=function(){show_hide(idThing);}; */
 384   }
 385 }
 386 /* Take n element IDs, prepare them for javascript enhanced
 387    display and hide the IDs by default. */
 388 function prep_pkg_descs()
 389 {
 390   if(document.getElementById && document.createTextNode) {
 391     for(var i=0; i<arguments.length; i++) {
 392       prep(arguments[i])
 393       show_hide(arguments[i]);
 394     }
 395   }
 396 }
 397 </script>"))
 398
 399 \f
 400 (define (list-packages . args)
 401   "Return an HTML page listing all the packages found in the GNU distribution,
 402 with gnu.org server-side include and all that."
 403   ;; Don't attempt to translate descriptions.
 404   (setlocale LC_ALL "C")
 405
 406   ;; Output the page as UTF-8 since that's what the gnu.org server-side
 407   ;; headers claim.
 408   (set-port-encoding! (current-output-port) "UTF-8")
 409
 410   (let ((packages (sort (fold-packages cons '())
 411                         (lambda (p1 p2)
 412                           (string<? (package-name p1) (package-name p2))))))
 413    (format #t "<!--#include virtual=\"/server/html5-header.html\" -->
 414 <!-- Parent-Version: 1.70 $ -->
 415 <title>GNU Guix - GNU Distribution - GNU Project</title>
 416 ")
 417    (insert-css)
 418    (insert-js)
 419    (format #t "<!--#include virtual=\"/server/banner.html\" -->")
 420
 421    (sxml->xml (packages->sxml packages))
 422    (format #t "</div>
 423 <!--#include virtual=\"/server/footer.html\" -->
 424 <div id=\"footer\">
 425
 426 <p>Please send general FSF &amp; GNU inquiries to
 427 <a href=\"mailto:gnu@gnu.org\">&lt;gnu@gnu.org&gt;</a>.
 428 There are also <a href=\"/contact/\">other ways to contact</a>
 429 the FSF.  Broken links and other corrections or suggestions can be sent
 430 to <a href=\"mailto:bug-guix@gnu.org\">&lt;bug-guix@gnu.org&gt;</a>.</p>
 431
 432 <p>Copyright &copy; 2013 Free Software Foundation, Inc.</p>
 433
 434 <p>This page is licensed under a <a rel=\"license\"
 435 href=\"http://creativecommons.org/licenses/by-nd/3.0/us/\">Creative
 436 Commons Attribution-NoDerivs 3.0 United States License</a>.</p>
 437
 438 <p>Updated:
 439 <!-- timestamp start -->
 440 $Date$
 441 <!-- timestamp end -->
 442 </p>
 443 </div>
 444 </div>
 445 </body>
 446 </html>
 447 "))
 448   )
 449
 450 ;;; list-packages.scm ends here