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'.

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 */
+
+@import 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 <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org>
+;;; Copyright © 2013 Alex Sassmannshausen <alex.sassmannshausen@gmail.com>
 ;;; Initially written by Luis Felipe López Acevedo <felipe.lopez@openmailbox.org>
 ;;; 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"))