>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 */ + address@hidden url("article.css"); + +a { + transition: all 0.3s; +} +table#packages, table#packages tr, table#packages tbody, table#packages td, table#packages th { + border: 0px solid black; + clear: both; +} +table#packages tr:nth-child(even) { + background-color: #FFF; +} +table#packages tr:nth-child(odd) { + background-color: #EEE; +} +table#packages tr:hover, table#packages tr:focus, table#packages tr:active { + background-color: #DDD; +} +table#packages th { + background-color: #333; + color: #fff; +} +table#packages td { + margin:0px; + padding:0.2em 0.5em; +} +table#packages td:first-child { + width:10%; + text-align:center; +} +table#packages td:nth-child(2) { + width:30%; +} +table#packages td:last-child { + width:60%; +} +img.package-logo { + float: left; + padding: 0.75em; +} +table#packages span { + font-weight: 700; +} +table#packages span a { + float: right; + font-weight: 500; +} +a#top { + position:fixed; + right:10px; + bottom:10px; + font-size:150%; + background-color:#EEE; + padding:10px 7.5px 0 7.5px; + text-decoration:none; + color:#000; + border-radius:5px; +} +a#top:hover, a#top:focus { + background-color:#333; + color:#fff; +} \ No newline at end of file diff --git a/website/static/base/js/packages.js b/website/static/base/js/packages.js new file mode 100644 index 0000000..c8d9fc4 --- /dev/null +++ b/website/static/base/js/packages.js @@ -0,0 +1,46 @@ +/* license: CC0 */ + +function show_hide(idThing) +{ + if(document.getElementById && document.createTextNode) { + var thing = document.getElementById(idThing); + /* Used to change the link text, depending on whether description is + collapsed or expanded */ + var thingLink = thing.previousSibling.lastChild.firstChild; + if (thing) { + if (thing.style.display == "none") { + thing.style.display = ""; + thingLink.data = 'Collapse'; + } else { + thing.style.display = "none"; + thingLink.data = 'Expand'; + } + } + } +} + +/* Add controllers used for collapse/expansion of package descriptions */ +function prep(idThing) +{ + var tdThing = document.getElementById(idThing).parentNode; + if (tdThing) { + var aThing = tdThing.firstChild.appendChild(document.createElement('a')); + aThing.setAttribute('href', 'javascript:void(0)'); + aThing.setAttribute('title', 'show/hide package description'); + aThing.appendChild(document.createTextNode('Expand')); + aThing.onclick=function(){show_hide(idThing);}; + /* aThing.onkeypress=function(){show_hide(idThing);}; */ + } +} + +/* Take n element IDs, prepare them for javascript enhanced + display and hide the IDs by default. */ +function prep_pkg_descs() +{ + if(document.getElementById && document.createTextNode) { + for(var i=0; i\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 +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2015 Mathieu Lirzin +;;; Copyright © 2013 Alex Sassmannshausen ;;; Initially written by Luis Felipe López Acevedo ;;; who waives all copyright interest on this file. ;;; @@ -20,12 +21,236 @@ ;;; along with GuixSD website. If not, see . (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) + (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")) -- 2.1.4