>From ab91cf5468669c80ea13f0540c53e8f8c8faedb5 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin
Date: Sun, 14 Jun 2015 19:13:12 +0200
Subject: [PATCH 2/2] website: packages: List packages.
Integrate 'build-aux/list-packages.scm' from the Guix repository in the
GuixSD website instead of using an external link. Export of the package
list is optional since it requires to have Guix locally.
* website/static/base/css/packages.css: New file.
* website/static/base/js/packages.js: Likewise.
* website/www.scm (export-web-site): Add #:packages parameter.
* website/www/packages.scm (lookup-gnu-package, list-join)
(package->sxml, packages->sxml): New procedures.
(packages-page): Use them.
* website/www/shared.scm (html-page-description): Use 'packages-page'.
---
website/static/base/css/packages.css | 64 ++++++++++
website/static/base/js/packages.js | 46 +++++++
website/www.scm | 26 ++--
website/www/packages.scm | 236 ++++++++++++++++++++++++++++++++++-
website/www/shared.scm | 2 +-
5 files changed, 357 insertions(+), 17 deletions(-)
create mode 100644 website/static/base/css/packages.css
create mode 100644 website/static/base/js/packages.js
diff --git a/website/static/base/css/packages.css b/website/static/base/css/packages.css
new file mode 100644
index 0000000..d9771be
--- /dev/null
+++ b/website/static/base/css/packages.css
@@ -0,0 +1,64 @@
+/* license: CC0 */
+
address@hidden url("article.css");
+
+a {
+ transition: all 0.3s;
+}
+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 th {
+ 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;
+}
\ No newline at end of file
diff --git a/website/static/base/js/packages.js b/website/static/base/js/packages.js
new file mode 100644
index 0000000..c8d9fc4
--- /dev/null
+++ b/website/static/base/js/packages.js
@@ -0,0 +1,46 @@
+/* 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\n" port)
(sxml->xml page port))))
-(define* (export-web-site #:optional (directory "."))
- "Export the whole web site as HTML files created in DIRECTORY."
+(define* (export-web-site #:optional (directory ".") #:key (packages #f))
+ "Export the whole web site as HTML files created in DIRECTORY. By
+default the PACKAGES page (which require to have Guix in '%load-path')
+is not exported."
(for-each (match-lambda
- ((filename page)
- (export-web-page (page)
- (string-append directory
- file-name-separator-string
- filename))))
- %web-pages))
+ ((filename page)
+ (export-web-page (page)
+ (string-append directory
+ file-name-separator-string
+ filename))))
+ (if packages
+ (cons (list "packages/index.html" packages-page) %web-pages)
+ %web-pages)))
;; Local Variables:
;; eval: (put 'sxml-match 'scheme-indent-function 1)
diff --git a/website/www/packages.scm b/website/www/packages.scm
index 4d0bdb3..60f78c5 100644
--- a/website/www/packages.scm
+++ b/website/www/packages.scm
@@ -1,6 +1,7 @@
;;; GuixSD website --- GNU's advanced distro website
-;;; Copyright © 2015 Ludovic Courtès
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès
;;; Copyright © 2015 Mathieu Lirzin
+;;; Copyright © 2013 Alex Sassmannshausen
;;; Initially written by Luis Felipe López Acevedo
;;; who waives all copyright interest on this file.
;;;
@@ -20,12 +21,236 @@
;;; along with GuixSD website. If not, see .
(define-module (www packages)
+ #:use-module (www utils)
#:use-module (www shared)
+ #: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 (packages-page))
+(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 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
+ ,(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 ,(gnu-url "/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 SXML table describing PACKAGES."
+ `(div
+ (table (@ (id "packages"))
+ (tr (th "GNU?")
+ (th "Package version")
+ (th "Package details"))
+ ,@(fold-values package->sxml packages '() '() (length packages)))
+ (a (@ (href "#content-box")
+ (title "Back to top.")
+ (id "top"))
+ "^")))
+
+
(define (packages-page)
`(html (@ (lang "en"))
- ,(html-page-header "Packages")
+ ,(html-page-header "Packages" #:css "packages.css" #:js "packages.js")
(body
,(html-page-description)
,(html-page-links)
@@ -39,5 +264,10 @@ transparently "
". This is a complete lists of the packages. Our "
(a (@ (href "http://hydra.gnu.org/jobset/gnu/master"))
"continuous integration system")
- " shows their current build status.")))
+ " shows their current build status.")
+ ,(let ((packages (sort (fold-packages cons '())
+ (lambda (p1 p2)
+ (string (package-name p1)
+ (package-name p2))))))
+ (packages->sxml packages))))
,(html-page-footer))))
diff --git a/website/www/shared.scm b/website/www/shared.scm
index 6b19db9..40360f3 100644
--- a/website/www/shared.scm
+++ b/website/www/shared.scm
@@ -80,7 +80,7 @@ Functional package management,")))
(alt "GuixSD"))))
(ul (@ (id "site-nav"))
(li (a (@ (href ,(base-url "download"))) "Download"))
- (li (a (@ (href ,(guix-url "package-list.html"))) "Packages"))
+ (li (a (@ (href ,(base-url "packages"))) "Packages"))
(li (a (@ (href ,(base-url "help"))) "Help"))
(li (a (@ (href ,(base-url "contribute"))) "Contribute"))
(li (a (@ (href ,(base-url "donate"))) "Donate"))
--
2.1.4