[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/02: website: packages: List packages.
|
From: |
Mathieu Lirzin |
|
Subject: |
02/02: website: packages: List packages. |
|
Date: |
Wed, 17 Jun 2015 20:13:45 +0000 |
mthl pushed a commit to branch master
in repository guix-artwork.
commit 1dd8ad0da24941f05e0830dc077316690719b75c
Author: Mathieu Lirzin <address@hidden>
Date: Sun Jun 14 19:13:12 2015 +0200
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/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 | 4 +-
website/www/packages.scm | 236 +++++++++++++++++++++++++++++++++-
website/www/shared.scm | 3 +-
5 files changed, 346 insertions(+), 7 deletions(-)
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<arguments.length; i++) {
+ prep(arguments[i])
+ show_hide(arguments[i]);
+ }
+ }
+}
diff --git a/website/www.scm b/website/www.scm
index 027febc..49d5c67 100644
--- a/website/www.scm
+++ b/website/www.scm
@@ -331,9 +331,7 @@ Distribution.")
("donate/index.html" ,donate-page)
("download/index.html" ,download-page)
("help/index.html" ,help-page)
-
- ;; XXX: The following one is not ready yet.
- ;; ("packages/index.html" ,packages-page)
+ ;; ("packages/index.html" ,packages-page) ; Need Guix
))
(define (mkdir* directory)
diff --git a/website/www/packages.scm b/website/www/packages.scm
index 4d0bdb3..f0db089 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 <address@hidden>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
;;; Copyright © 2015 Mathieu Lirzin <address@hidden>
+;;; Copyright © 2013 Alex Sassmannshausen <address@hidden>
;;; Initially written by Luis Felipe López Acevedo <address@hidden>
;;; who waives all copyright interest on this file.
;;;
@@ -20,12 +21,236 @@
;;; along with GuixSD website. If not, see <http://www.gnu.org/licenses/>.
(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 773fcc0..29676ea 100644
--- a/website/www/shared.scm
+++ b/website/www/shared.scm
@@ -78,7 +78,8 @@ 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"))
+ ;; Note: valid only if `packages-page' is exported.
+ (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"))