mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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.
This commit is contained in:
Mathieu Lirzin
parent
2c04921634
commit
4192e898a4
2 changed files with 0 additions and 451 deletions
|
|
@ -264,7 +264,6 @@ EXTRA_DIST = \
|
|||
build-aux/check-available-binaries.scm \
|
||||
build-aux/check-final-inputs-self-contained.scm \
|
||||
build-aux/download.scm \
|
||||
build-aux/list-packages.scm \
|
||||
build-aux/make-binary-tarball.scm \
|
||||
srfi/srfi-37.scm.in \
|
||||
srfi/srfi-64.scm \
|
||||
|
|
|
|||
|
|
@ -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 & GNU inquiries to
|
||||
<a href=\"mailto:gnu@gnu.org\"><gnu@gnu.org></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\"><bug-guix@gnu.org></a>.</p>
|
||||
|
||||
<p>Copyright © 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
|
||||
Loading…
Reference in a new issue