aboutsummaryrefslogtreecommitdiff
path: root/build-aux
diff options
context:
space:
mode:
Diffstat (limited to 'build-aux')
-rwxr-xr-xbuild-aux/list-packages.scm450
1 files changed, 0 insertions, 450 deletions
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
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-07 03:25:36 +0000