From mboxrd@z Thu Jan 1 00:00:00 1970 From: Mathieu Lirzin Subject: [PATCH] Integrate the package list in the website. Date: Sun, 14 Jun 2015 21:17:17 +0200 Message-ID: <87mw02nlqa.fsf@openmailbox.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:60593) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Z4DQO-0000xP-5O for guix-devel@gnu.org; Sun, 14 Jun 2015 15:18:35 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Z4DQK-0000Qg-6J for guix-devel@gnu.org; Sun, 14 Jun 2015 15:18:32 -0400 Received: from smtp4.openmailbox.org ([62.4.1.38]:37858) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Z4DQJ-0000Pb-MT for guix-devel@gnu.org; Sun, 14 Jun 2015 15:18:28 -0400 Received: from localhost (localhost [127.0.0.1]) by mail2.openmailbox.org (Postfix) with ESMTP id E2B76200091 for ; Sun, 14 Jun 2015 21:18:23 +0200 (CEST) Received: from mail2.openmailbox.org ([62.4.1.33]) by localhost (mail.openmailbox.org [127.0.0.1]) (amavisd-new, port 10026) with ESMTP id bdwQePkf-jkJ for ; Sun, 14 Jun 2015 21:18:17 +0200 (CEST) List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: guix-devel@gnu.org --=-=-= Content-Type: text/plain 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: --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: attachment; filename=0001-website-Allow-inclusion-of-Javascript.patch Content-Transfer-Encoding: quoted-printable >From aff0743966b06d524acc1d0be86f46b4b0a20828 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin 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")) =20 -(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 " =E2=80=94 GuixSD")))) + (title ,(string-append title " =E2=80=94 GuixSD")) + ,(if (string-null? js) + "" + `(script (@ (src ,(js-url js))) "")))) =20 (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)) =20 +(define (js-url file) + (string-append (static-base-url) "js/" file)) + (define (image-url file) (string-append (static-base-url) "img/" file)) =20 --=20 2.1.4 --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: attachment; filename=0002-website-packages-List-packages.patch Content-Transfer-Encoding: quoted-printable >From ab91cf5468669c80ea13f0540c53e8f8c8faedb5 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 14 Jun 2015 19:13:12 +0200 Subject: [PATCH 2/2] website: packages: List packages. Integrate 'build-aux/list-packages.scm' from the Guix repository in the GuixSD website instead of using an external link. Export of the package list is optional since it requires to have Guix locally. * website/static/base/css/packages.css: New file. * website/static/base/js/packages.js: Likewise. * website/www.scm (export-web-site): Add #:packages parameter. * website/www/packages.scm (lookup-gnu-package, list-join) (package->sxml, packages->sxml): New procedures. (packages-page): Use them. * website/www/shared.scm (html-page-description): Use 'packages-page'. --- website/static/base/css/packages.css | 64 ++++++++++ website/static/base/js/packages.js | 46 +++++++ website/www.scm | 26 ++-- website/www/packages.scm | 236 +++++++++++++++++++++++++++++++= +++- website/www/shared.scm | 2 +- 5 files changed, 357 insertions(+), 17 deletions(-) create mode 100644 website/static/base/css/packages.css create mode 100644 website/static/base/js/packages.js diff --git a/website/static/base/css/packages.css b/website/static/base/css= /packages.css new file mode 100644 index 0000000..d9771be --- /dev/null +++ b/website/static/base/css/packages.css @@ -0,0 +1,64 @@ +/* license: CC0 */ + +@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/pa= ckages.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 =3D document.getElementById(idThing); + /* Used to change the link text, depending on whether description is + collapsed or expanded */ + var thingLink =3D thing.previousSibling.lastChild.firstChild; + if (thing) { + if (thing.style.display =3D=3D "none") { + thing.style.display =3D ""; + thingLink.data =3D 'Collapse'; + } else { + thing.style.display =3D "none"; + thingLink.data =3D 'Expand'; + } + } + } +} + +/* Add controllers used for collapse/expansion of package descriptions */ +function prep(idThing) +{ + var tdThing =3D document.getElementById(idThing).parentNode; + if (tdThing) { + var aThing =3D 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=3Dfunction(){show_hide(idThing);}; + /* aThing.onkeypress=3Dfunction(){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=3D0; i\n" port) (sxml->xml page port)))) =20 -(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))) =20 ;; 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 =C2=A9 2015 Ludovic Court=C3=A8s +;;; Copyright =C2=A9 2013, 2014, 2015 Ludovic Court=C3=A8s ;;; Copyright =C2=A9 2015 Mathieu Lirzin +;;; Copyright =C2=A9 2013 Alex Sassmannshausen ;;; Initially written by Luis Felipe L=C3=B3pez Acevedo ;;; who waives all copyright interest on this file. ;;; @@ -20,12 +21,236 @@ ;;; along with GuixSD website. If not, see . =20 (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)) =20 +(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=3D> (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/patc= hes/" + (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=3D? + %hydra-supported-systems + (package-transitive-supported-systems package)= )) + " "))) + + (define (package-logo name) + (and=3D> (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 ((=3D remaining 1) ; Last package in packages + (values + (reverse ; Fold has reversed pack= ages + (cons (insert-tr description-id 'js) ; Prefix final sxml + previous)) + '() ; No more work to do + 0)) ; End of the line + ((=3D (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) + (stringsxml 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")) --=20 2.1.4 --=-=-= Content-Type: text/plain guix: --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: attachment; filename=0001-list-packages-Move-to-guix-artwork.patch Content-Transfer-Encoding: quoted-printable >From 15b73de6b2910fc1a0a000780c786adc4c0c4404 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin 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 =3D \ 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 =C2=A9 2013, 2014, 2015 Ludovic Court=C3=A8s -;;; Copyright =C2=A9 2013 Alex Sassmannshausen -;;; -;;; 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 . - -(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 nu= mber -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=3D> (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/patc= hes/" - (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=3D? - %hydra-supported-systems - (package-transitive-supported-systems package)= )) - " "))) - - (define (package-logo name) - (and=3D> (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 ((=3D remaining 1) ; Last package in packages - (values - (reverse ; Fold has reversed pack= ages - (cons (insert-tr description-id 'js) ; Prefix final sxml - previous)) - '() ; No more work to do - 0)) ; End of the line - ((=3D (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 -"")) - -(define (insert-js) - "Return the JavaScript for the list-packages page." - (format #t -"")) - - -(define (list-packages . args) - "Return an HTML page listing all the packages found in the GNU distribut= ion, -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 - -GNU Guix - GNU Distribution - GNU Project -") - (insert-css) - (insert-js) - (format #t "") - - (sxml->xml (packages->sxml packages)) - (format #t " - -
- -

Please send general FSF & GNU inquiries to -<gnu@gnu.org>. -There are also other ways to contact -the FSF. Broken links and other corrections or suggestions can be sent -to <bug-guix@gnu.org>.

- -

Copyright © 2013 Free Software Foundation, Inc.

- -

This page is licensed under a Creative -Commons Attribution-NoDerivs 3.0 United States License.

- -

Updated: - -$Date$ - -

-
- - - -")) - ) - -;;; list-packages.scm ends here --=20 2.1.4 --=-=-= Content-Type: text/plain -- Mathieu Lirzin --=-=-=--