From 4192e898a4256bab275f75d744969dfab8e06b6d Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@openmailbox.org>
Date: Sun, 14 Jun 2015 20:52:42 +0200
Subject: list-packages: Move to guix-artwork repository.

In order to integrate the package list in the GuixSD website, the listing of
packages has been moved into the website implementation.

* build-aux/list-packages.scm: Remove file.
* Makefile.am (EXTRA_DIST): Adapt to it.
---
 build-aux/list-packages.scm | 450 --------------------------------------------
 1 file changed, 450 deletions(-)
 delete mode 100755 build-aux/list-packages.scm

(limited to 'build-aux/list-packages.scm')

diff --git a/build-aux/list-packages.scm b/build-aux/list-packages.scm
deleted file mode 100755
index c4f445291b..0000000000
--- a/build-aux/list-packages.scm
+++ /dev/null
@@ -1,450 +0,0 @@
-#!/bin/sh
-exec guile -l "$0"                              \
-  -c '(apply (@ (list-packages) list-packages)
-             (cdr (command-line)))'
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2013 Alex Sassmannshausen <alex.sassmannshausen@gmail.com>
-;;;
-;;; 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 ((guix download) #:select (%mirrors))
-  #:use-module ((guix build download) #:select (maybe-expand-mirrors))
-  #:use-module (gnu packages)
-  #:use-module (sxml simple)
-  #:use-module (sxml fold)
-  #:use-module (web uri)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  #:export (list-packages))
-
-;;; Commentary:
-;;;
-;;; Emit an HTML representation of the packages available in GNU Guix.
-;;;
-;;; Code:
-
-(define lookup-gnu-package
-  (let ((gnu (official-gnu-packages)))
-    (lambda (name)
-      "Return the package description for GNU package NAME, or #f."
-      (find (lambda (package)
-              (equal? (gnu-package-name package) name))
-            gnu))))
-
-(define (list-join lst item)
-  "Join the items in LST by inserting ITEM between each pair of elements."
-  (let loop ((lst    lst)
-             (result '()))
-    (match lst
-      (()
-       (match (reverse result)
-         (()
-          '())
-         ((_ rest ...)
-          rest)))
-      ((head tail ...)
-       (loop tail
-             (cons* head item result))))))
-
-(define (package->sxml package previous description-ids remaining)
-  "Return 3 values: the HTML-as-SXML for PACKAGE added to all previously
-collected package output in PREVIOUS, a list of DESCRIPTION-IDS and the number
-of packages still to be processed in REMAINING.  Also Introduces a call to the
-JavaScript prep_pkg_descs function as part of the output of PACKAGE, every
-time the length of DESCRIPTION-IDS, increasing, is 15 or when REMAINING,
-decreasing, is 1."
-  (define (location-url loc)
-    (string-append "http://git.savannah.gnu.org/cgit/guix.git/tree/"
-                   (location-file loc) "#n"
-                   (number->string (location-line loc))))
-
-  (define (source-url package)
-    (let ((loc (package-location package)))
-      (and loc (location-url 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)
-                         (title "Link to the full license"))
-                      ,(license-name license))))
-            (else
-             `(div ,(license-name license) " ("
-                   ,(license-comment license) ")")))))
-       (#f "")))
-
-    (->sxml (package-license package)))
-
-  (define (patches package)
-    (define patch-url
-      (match-lambda
-       ((? string? patch)
-        (string-append
-         "http://git.savannah.gnu.org/cgit/guix.git/tree/gnu/packages/patches/"
-         (basename patch)))
-       ((? origin? patch)
-        (uri->string
-         (first (maybe-expand-mirrors (string->uri
-                                       (match (origin-uri patch)
-                                         ((? string? uri) uri)
-                                         ((head . tail) head)))
-                                      %mirrors))))))
-
-    (define patch-name
-      (match-lambda
-       ((? string? patch)
-        (basename patch))
-       ((? origin? patch)
-        (match (origin-uri patch)
-          ((? string? uri) (basename uri))
-          ((head . tail) (basename head))))))
-
-    (define (snippet-link snippet)
-      (let ((loc (or (package-field-location package 'source)
-                     (package-location package))))
-        `(a (@ (href ,(location-url loc))
-               (title "Link to patch snippet"))
-            "snippet")))
-
-    (and (origin? (package-source package))
-         (let ((patches (origin-patches (package-source package)))
-               (snippet (origin-snippet (package-source package))))
-           (and (or (pair? patches) snippet)
-                `(div "patches: "
-                      ,(let loop ((patches patches)
-                                  (number  1)
-                                  (links   '()))
-                         (match patches
-                           (()
-                            (let* ((additional (and snippet
-                                                    (snippet-link snippet)))
-                                   (links      (if additional
-                                                   (cons additional links)
-                                                   links)))
-                              (list-join (reverse links) ", ")))
-                           ((patch rest ...)
-                            (loop rest
-                                  (+ 1 number)
-                                  (cons `(a (@ (href ,(patch-url patch))
-                                               (title ,(string-append
-                                                        "Link to "
-                                                        (patch-name patch))))
-                                            ,(number->string number))
-                                        links))))))))))
-
-  (define (status package)
-    (define (url system)
-      `(a (@ (href ,(string-append "http://hydra.gnu.org/job/gnu/master/"
-                                   (package-full-name package) "."
-                                   system))
-             (title "View the status of this architecture's build at Hydra"))
-          ,system))
-
-    `(div "status: "
-          ,(list-join (map url
-                           (lset-intersection
-                            string=?
-                            %hydra-supported-systems
-                            (package-transitive-supported-systems package)))
-                      " ")))
-
-  (define (package-logo name)
-    (and=> (lookup-gnu-package name)
-           gnu-package-logo))
-
-  (define (insert-tr description-id js?)
-    (define (insert-js-call description-ids)
-      "Return an sxml call to prep_pkg_descs, with up to 15 elements of
-description-ids as formal parameters."
-      `(script (@ (type "text/javascript"))
-               ,(format #f "prep_pkg_descs(~a)"
-                        (string-append "'"
-                                       (string-join description-ids "', '")
-                                       "'"))))
-
-    (let ((description-ids (cons description-id description-ids)))
-      `(tr (td ,(if (gnu-package? package)
-                    `(img (@ (src "/graphics/gnu-head-mini.png")
-                             (alt "Part of GNU")
-                             (title "Part of GNU")))
-                    ""))
-           (td (a (@ (href ,(source-url package))
-                     (title "Link to the Guix package source code"))
-                  ,(package-name package) " "
-                  ,(package-version package)))
-           (td (span ,(package-synopsis package))
-               (div (@ (id ,description-id))
-                    ,(match (package-logo (package-name package))
-                       ((? string? url)
-                        `(img (@ (src ,url)
-                                 (height "35")
-                                 (class "package-logo")
-                                 (alt ("Logo of " ,(package-name package))))))
-                       (_ #f))
-                    (p ,(package-description package))
-                    ,(license package)
-                    (a (@ (href ,(package-home-page package))
-                          (title "Link to the package's website"))
-                       ,(package-home-page package))
-                    ,(status package)
-                    ,(patches package)
-                    ,(if js?
-                         (insert-js-call description-ids)
-                         ""))))))
-
-  (let ((description-id (symbol->string
-                         (gensym (package-name package)))))
-    (cond ((= remaining 1)              ; Last package in packages
-           (values
-            (reverse                              ; Fold has reversed packages
-             (cons (insert-tr description-id 'js) ; Prefix final sxml
-                   previous))
-            '()                            ; No more work to do
-            0))                            ; End of the line
-          ((= (length description-ids) 15) ; Time for a JS call
-           (values
-            (cons (insert-tr description-id 'js)
-                  previous)    ; Prefix new sxml
-            '()                ; Reset description-ids
-            (1- remaining)))   ; Reduce remaining
-          (else                ; Insert another row, and build description-ids
-           (values
-            (cons (insert-tr description-id #f)
-                  previous)                       ; Prefix new sxml
-            (cons description-id description-ids) ; Update description-ids
-            (1- remaining))))))                   ; Reduce remaining
-
-(define (packages->sxml packages)
-  "Return an HTML page as SXML describing PACKAGES."
-  `(div
-    (h2 "GNU Guix Package List")
-    (div (@ (id "intro"))
-         (div
-          (img (@ (src "graphics/GuixSD-V.png")
-                  (alt "Guix System Distribution")
-                  (height "83"))))
-         (p "This web page lists the packages currently provided by the "
-            (a (@ (href "manual/guix.html#GNU-Distribution"))
-               "Guix System Distribution")
-            ".  "
-            "Our " (a (@ (href "http://hydra.gnu.org/jobset/gnu/master"))
-                      "continuous integration system")
-            " shows their current build status."))
-    (table (@ (id "packages"))
-           (tr (th "GNU?")
-               (th "Package version")
-               (th "Package details"))
-           ,@(fold-values package->sxml packages '() '() (length packages)))
-    (a (@ (href "#intro")
-          (title "Back to top.")
-          (id "top"))
-       "^")))
-
-
-(define (insert-css)
-  "Return the CSS for the list-packages page."
-  (format #t
-"<style>
-/* license: CC0 */
-a {
-    transition: all 0.3s;
-}
-div#intro {
-    margin-bottom: 2em;
-}
-div#intro div, div#intro p {
-    padding:0.5em;
-}
-div#intro div {
-    float:left;
-}
-div#intro img {
-    float:left;
-    padding:0.75em;
-}
-table#packages, table#packages tr, table#packages tbody, table#packages td, table#packages th {
-    border: 0px solid black;
-    clear: both;
-}
-table#packages tr:nth-child(even) {
-    background-color: #FFF;
-}
-table#packages tr:nth-child(odd) {
-    background-color: #EEE;
-}
-table#packages tr:hover, table#packages tr:focus, table#packages tr:active {
-    background-color: #DDD;
-}
-table#packages tr:first-child, table#packages tr:first-child:hover, table#packages tr:first-child:focus, table#packages tr:first-child:active {
-    background-color: #333;
-    color: #fff;
-}
-table#packages td {
-    margin:0px;
-    padding:0.2em 0.5em;
-}
-table#packages td:first-child {
-    width:10%;
-    text-align:center;
-}
-table#packages td:nth-child(2) {
-    width:30%;
-}
-table#packages td:last-child {
-    width:60%;
-}
-img.package-logo {
-    float: left;
-    padding: 0.75em;
-}
-table#packages span {
-    font-weight: 700;
-}
-table#packages span a {
-    float: right;
-    font-weight: 500;
-}
-a#top {
-    position:fixed;
-    right:10px;
-    bottom:10px;
-    font-size:150%;
-    background-color:#EEE;
-    padding:10px 7.5px 0 7.5px;
-    text-decoration:none;
-    color:#000;
-    border-radius:5px;
-}
-a#top:hover, a#top:focus {
-    background-color:#333;
-    color:#fff;
-}
-</style>"))
-
-(define (insert-js)
-  "Return the JavaScript for the list-packages page."
-  (format #t
-"<script type=\"text/javascript\">
-// license: CC0
-function show_hide(idThing)
-{
-  if(document.getElementById && document.createTextNode) {
-    var thing = document.getElementById(idThing);
-    /* Used to change the link text, depending on whether description is
-       collapsed or expanded */
-    var thingLink = thing.previousSibling.lastChild.firstChild;
-    if (thing) {
-      if (thing.style.display == \"none\") {
-        thing.style.display = \"\";
-        thingLink.data = 'Collapse';
-      } else {
-        thing.style.display = \"none\";
-        thingLink.data = 'Expand';
-      }
-    }
-  }
-}
-/* Add controllers used for collapse/expansion of package descriptions */
-function prep(idThing)
-{
-  var tdThing = document.getElementById(idThing).parentNode;
-  if (tdThing) {
-    var aThing = tdThing.firstChild.appendChild(document.createElement('a'));
-    aThing.setAttribute('href', 'javascript:void(0)');
-    aThing.setAttribute('title', 'show/hide package description');
-    aThing.appendChild(document.createTextNode('Expand'));
-    aThing.onclick=function(){show_hide(idThing);};
-    /* aThing.onkeypress=function(){show_hide(idThing);}; */
-  }
-}
-/* Take n element IDs, prepare them for javascript enhanced
-   display and hide the IDs by default. */
-function prep_pkg_descs()
-{
-  if(document.getElementById && document.createTextNode) {
-    for(var i=0; i<arguments.length; i++) {
-      prep(arguments[i])
-      show_hide(arguments[i]);
-    }
-  }
-}
-</script>"))
-
-
-(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."
-  ;; Don't attempt to translate descriptions.
-  (setlocale LC_ALL "C")
-
-  ;; Output the page as UTF-8 since that's what the gnu.org server-side
-  ;; headers claim.
-  (set-port-encoding! (current-output-port) "UTF-8")
-
-  (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>
-")
-   (insert-css)
-   (insert-js)
-   (format #t "<!--#include virtual=\"/server/banner.html\" -->")
-
-   (sxml->xml (packages->sxml packages))
-   (format #t "</div>
-<!--#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
-- 
cgit v1.2.3