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:
>From aff0743966b06d524acc1d0be86f46b4b0a20828 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <m...@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
>From ab91cf5468669c80ea13f0540c53e8f8c8faedb5 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <m...@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 <l...@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <l...@gnu.org>
;;; Copyright © 2015 Mathieu Lirzin <m...@openmailbox.org>
+;;; Copyright © 2013 Alex Sassmannshausen <alex.sassmannshau...@gmail.com>
;;; Initially written by Luis Felipe López Acevedo <felipe.lo...@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 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
guix:
>From 15b73de6b2910fc1a0a000780c786adc4c0c4404 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <m...@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 <l...@gnu.org>
-;;; Copyright © 2013 Alex Sassmannshausen <alex.sassmannshau...@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:g...@gnu.org\"><g...@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-g...@gnu.org\"><bug-g...@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
--
2.1.4
--
Mathieu Lirzin
