[PATCH] Integrate the package list in the website.

[PATCH] Integrate the package list in the website.

[Mathieu Lirzin]

[-- Attachment #1: Type: text/plain, Size: 308 bytes --]

Hello Guix,

I would like some advice on how to add copyright notices in
'website/static/base/css/packages.css' and
'website/static/base/js/packages.js'. Futhermore I would like
suggestions about my commit messages, in order to make then
precise. Other comments or reviews are welcome too ;-)

guix-artwork:

[-- Attachment #2: 0001-website-Allow-inclusion-of-Javascript.patch --]
[-- Type: text/x-diff, Size: 1947 bytes --]

From aff0743966b06d524acc1d0be86f46b4b0a20828 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@openmailbox.org>
Date: Sun, 14 Jun 2015 20:06:40 +0200
Subject: [PATCH 1/2] website: Allow inclusion of Javascript.

* website/www/utils.scm (js-url): New procedure.
* website/www/shared.scm (html-page-header): Use it. Add #:js parameter.
---
 website/www/shared.scm | 7 +++++--
 website/www/utils.scm  | 4 ++++
 2 files changed, 9 insertions(+), 2 deletions(-)

diff --git a/website/www/shared.scm b/website/www/shared.scm
index 88dad4e..6b19db9 100644
--- a/website/www/shared.scm
+++ b/website/www/shared.scm
@@ -30,7 +30,7 @@
 (define latest-guix-version
   (make-parameter "0.8.2"))
 
-(define* (html-page-header title #:key (css "article.css"))
+(define* (html-page-header title #:key (css "article.css") (js ""))
   `(head (meta (@ (charset "utf-8")))
 	 (meta (@ (name "author")
 		  (content "GuixSD Contributors")))
@@ -58,7 +58,10 @@ Functional package management,")))
 		  (rel "icon")
 		  (href ,(image-url "favicon.png"))))
 	 (link (@ (rel "license") (href "Pending...")))
-	 (title ,(string-append title " — GuixSD"))))
+	 (title ,(string-append title " — GuixSD"))
+	 ,(if (string-null? js)
+	      ""
+	      `(script (@ (src ,(js-url js))) ""))))
 
 (define (html-page-description)
   `(div (@ (class "message-box msg-info"))
diff --git a/website/www/utils.scm b/website/www/utils.scm
index 96ccb5f..029951f 100644
--- a/website/www/utils.scm
+++ b/website/www/utils.scm
@@ -28,6 +28,7 @@
 	    guix-url
 	    static-base-url
 	    css-url
+	    js-url
 	    image-url
 	    thumb-url
 	    screenshot-url
@@ -66,6 +67,9 @@
 (define (css-url file)
   (string-append (static-base-url) "css/" file))
 
+(define (js-url file)
+  (string-append (static-base-url) "js/" file))
+
 (define (image-url file)
   (string-append (static-base-url) "img/" file))
 
-- 
2.1.4


[-- Attachment #3: 0002-website-packages-List-packages.patch --]
[-- Type: text/x-diff, Size: 17945 bytes --]

From ab91cf5468669c80ea13f0540c53e8f8c8faedb5 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@openmailbox.org>
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 */
+
+@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..f6f61da 100644
--- a/website/www.scm
+++ b/website/www.scm
@@ -330,11 +330,7 @@ Distribution.")
     ("contribute/index.html" ,contribute-page)
     ("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)
-    ))
+    ("help/index.html" ,help-page)))
 
 (define (mkdir* directory)
   "Make DIRECTORY unless it already exists."
@@ -353,15 +349,19 @@ Distribution.")
       (display "<!DOCTYPE html>\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 <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"))
+       "^")))
+
+\f
 (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


[-- Attachment #4: Type: text/plain, Size: 7 bytes --]


guix:

[-- Attachment #5: 0001-list-packages-Move-to-guix-artwork.patch --]
[-- Type: text/x-diff, Size: 17864 bytes --]

From 15b73de6b2910fc1a0a000780c786adc4c0c4404 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@openmailbox.org>
Date: Sun, 14 Jun 2015 20:52:42 +0200
Subject: [PATCH] list-packages: Move to guix-artwork repository.

In order to integrate the package list with 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.
---
 Makefile.am                 |   1 -
 build-aux/list-packages.scm | 450 --------------------------------------------
 2 files changed, 451 deletions(-)
 delete mode 100755 build-aux/list-packages.scm

diff --git a/Makefile.am b/Makefile.am
index 2b84467..c8d701b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -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					\
diff --git a/build-aux/list-packages.scm b/build-aux/list-packages.scm
deleted file mode 100755
index c4f4452..0000000
--- 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"))
-       "^")))
-
-\f
-(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>"))
-
-\f
-(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
-- 
2.1.4


[-- Attachment #6: Type: text/plain, Size: 20 bytes --]


--
Mathieu Lirzin

Re: [PATCH] Integrate the package list in the website.

[Ludovic Courtès]

Mathieu Lirzin <mthl@openmailbox.org> skribis:

> I would like some advice on how to add copyright notices in
> 'website/static/base/css/packages.css' and
> 'website/static/base/js/packages.js'. Futhermore I would like
> suggestions about my commit messages, in order to make then
> precise. Other comments or reviews are welcome too ;-)

Both the CSS and JS are under CC0, so I think the simple “license: CC0”
is enough (and hopefully recognized by LibreJS.)

> From aff0743966b06d524acc1d0be86f46b4b0a20828 Mon Sep 17 00:00:00 2001
> From: Mathieu Lirzin <mthl@openmailbox.org>
> Date: Sun, 14 Jun 2015 20:06:40 +0200
> Subject: [PATCH 1/2] website: Allow inclusion of Javascript.
>
> * website/www/utils.scm (js-url): New procedure.
> * website/www/shared.scm (html-page-header): Use it. Add #:js parameter.

[...]

> -(define* (html-page-header title #:key (css "article.css"))
> +(define* (html-page-header title #:key (css "article.css") (js ""))

Make it just js (meaning #:js defaults to #f) and...

> +	 ,(if (string-null? js)
> +	      ""
> +	      `(script (@ (src ,(js-url js))) ""))))

... make it ,(if js `(script ...) "").
(It’s more idiomatic.)

> From ab91cf5468669c80ea13f0540c53e8f8c8faedb5 Mon Sep 17 00:00:00 2001
> From: Mathieu Lirzin <mthl@openmailbox.org>
> 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'.

[...]

> --- a/website/www.scm
> +++ b/website/www.scm
> @@ -330,11 +330,7 @@ Distribution.")
>      ("contribute/index.html" ,contribute-page)
>      ("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)
> -    ))
> +    ("help/index.html" ,help-page)))
>  
>  (define (mkdir* directory)
>    "Make DIRECTORY unless it already exists."
> @@ -353,15 +349,19 @@ Distribution.")
>        (display "<!DOCTYPE html>\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))

I would leave both unchanged.  When we really want to export
package-list.html, we can just add it to %web-pages or use a single call
to ‘export-web-page’.

> From 15b73de6b2910fc1a0a000780c786adc4c0c4404 Mon Sep 17 00:00:00 2001
> From: Mathieu Lirzin <mthl@openmailbox.org>
> Date: Sun, 14 Jun 2015 20:52:42 +0200
> Subject: [PATCH] list-packages: Move to guix-artwork repository.
>
> In order to integrate the package list with 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.

OK to push with these changes.

Thank you!

Ludo’.

Re: [PATCH] Integrate the package list in the website.

[Ludovic Courtès]

I’ve uploaded the new web page and updated the script on hydra.gnu.org
that updates it every day:

  https://www.gnu.org/software/guix/package-list.html

As Mathieu told me, it looks OK, but there’s probably room for
improvement in the CSS of that page.  Felipe, what do you think?  :-)

Thanks again, Mathieu!

Ludo’.

Re: [PATCH] Integrate the package list in the website.

[Luis Felipe López Acevedo]

On 2015-06-18 04:44, ludo@gnu.org wrote:
> I’ve uploaded the new web page and updated the script on hydra.gnu.org
> that updates it every day:
> 
>   https://www.gnu.org/software/guix/package-list.html

Great!

> As Mathieu told me, it looks OK, but there’s probably room for
> improvement in the CSS of that page.  Felipe, what do you think?  :-)
> 

I also think it looks OK (for now) :)

Some comments:

One thing I found is that the page does not validate. "The error was: 
utf8 "\xE9" does not map to Unicode" (<https://validator.w3.org/>).

In my Web browser, the <title> of the page reads "Packages ? GuixSD". 
Maybe that question mark has something to do with the error above.

Also, I noticed that the page is starting to take more time to load, at 
least in this computer. What would you think of adding pagination? I 
can't help with the code right now, but I could draw a mockup this 
weekend.


> Thanks again, Mathieu!

Thanks, Mathieu!


-- 
Luis Felipe López Acevedo
http://sirgazil.bitbucket.org/

Re: [PATCH] Integrate the package list in the website.

[Ludovic Courtès]

Luis Felipe López Acevedo <felipe.lopez@openmailbox.org> skribis:

> One thing I found is that the page does not validate. "The error was:
> utf8 "\xE9" does not map to Unicode" (<https://validator.w3.org/>).
>
> In my Web browser, the <title> of the page reads "Packages ?
> GuixSD". Maybe that question mark has something to do with the error
> above.

Right, the page was exported in locale encoding (which happened to be
ASCII on hydra.gnu.org) instead of UTF-8.  Fixed in 1bc4c07.

> Also, I noticed that the page is starting to take more time to load,
> at least in this computer. What would you think of adding pagination?
> I can't help with the code right now, but I could draw a mockup this
> weekend.

I’m not sure what you mean by pagination.

What would be ideal would be to use the JS code found in guix-web
<https://git.dthompson.us/guix-web.git> that allows users to search for
packages (basically all the package data would still be available in the
client, just not displayed.)

WDYT?

(I’m not offering to help with this code, though. :-))

Thanks,
Ludo’.