From da3edd193269fdbdf264aa4362e3f9155649a428 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 13 Nov 2015 13:56:20 +0100 Subject: website: Add /packages/issues.html page. * website/www/packages.scm (location-url, source-url): New procedures, moved from... (package->sxml): ... here. (%fast-issue-checkers, %issue-checkers): New variables. (lint-checker-report, package-issues, issues->sxml, package->issue-sxml, packages->issue-sxml, all-packages): New procedures. (packages-page): Use 'all-packages'. (issues-page): New procedure. * website/www.scm (%web-pages): Add ISSUES-PAGE in a comment. --- website/www.scm | 1 + website/www/packages.scm | 138 ++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 125 insertions(+), 14 deletions(-) (limited to 'website') diff --git a/website/www.scm b/website/www.scm index 415e5b6..c4d7fcf 100644 --- a/website/www.scm +++ b/website/www.scm @@ -333,6 +333,7 @@ Distribution.") ("download/index.html" ,download-page) ("help/index.html" ,help-page) ;; ("packages/index.html" ,packages-page) ; Need Guix + ;; ("packages/issues.html" ,issues-page) )) (define (mkdir* directory) diff --git a/website/www/packages.scm b/website/www/packages.scm index e576f92..4b76bfe 100644 --- a/website/www/packages.scm +++ b/website/www/packages.scm @@ -23,12 +23,14 @@ (define-module (www packages) #:use-module (www utils) #:use-module (www shared) + #:use-module ((guix ui) #:select (guix-warning-port)) #: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 (guix scripts lint) #:use-module (gnu packages) #:use-module (sxml simple) #:use-module (sxml fold) @@ -37,6 +39,7 @@ #:use-module (ice-9 i18n) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (texinfo) #:use-module (texinfo html) #:export (packages-page)) @@ -64,6 +67,15 @@ (loop tail (cons* head item result)))))) +(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 (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 @@ -71,15 +83,6 @@ 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 @@ -268,6 +271,92 @@ description-ids as formal parameters." (make-locale LC_ALL "en_US.UTF-8")))) +;;; +;;; Issues reported by 'lint'. +;;; + +(define %fast-issue-checkers + ;; Runs in less than a minute for all the packages. + (remove (lambda (checker) + (case (lint-checker-name checker) + ((home-page source derivation) #t) + (else #f))) + %checkers)) + +(define %issue-checkers + ;; List of checkers used by default. + %fast-issue-checkers) + +(define (lint-checker-report checker package) + "Return the report generated by CHECKER for PACKAGE as a string. If the +result is the empty string, it means that CHECKER had nothing to complain about." + (call-with-output-string + (lambda (port) + (parameterize ((guix-warning-port port)) + ((lint-checker-check checker) package))))) + +(define (package-issues package checkers) + "Report issues for PACKAGE based on reports generated by CHECKERS. Each +issue is a CHECKER/REPORT tuple." + (let ((reports (map (cut lint-checker-report <> package) + checkers))) + (remove (match-lambda + ((_ "") #t) + (_ #f)) + (zip checkers reports)))) + +(define (issues->sxml package issues) + "Return an SXML tree representing ISSUES for PACKAGE, where ISSUES is a +list of checker/report tuples." + (if (null? issues) + "Nothing to declare!" + (let ((count (length issues))) + `(div + (div (b ,(number->string count) + ,(if (= count 1) " issue" " issues"))) + (table + ,@(map (match-lambda + ((checker report) + `(tr (td ,(lint-checker-name checker)) + (td (pre ,report))))) + issues)))))) + +(define* (package->issue-sxml package #:key (checkers %issue-checkers)) + "Return an SXML table row for PACKAGE containing all the reports generated +by CHECKERS." + (let ((issues (package-issues package checkers))) + (define name+version + (string-append (package-name package) " " + (package-version package))) + + `(tr (td (a (@ (name ,(package-full-name package)))) + (a (@ (href ,(source-url package)) + (title "Link to the Guix package source code")) + ,(if (null? issues) + name+version + `(b ,name+version)))) + (td ,(issues->sxml package issues))))) + +(define* (packages->issue-sxml packages #:key (checkers %issue-checkers)) + "Return an SXML tree representing the reports generated by CHECKERS for +PACKAGES." + `(table + ,@(map (lambda (package) + (package->issue-sxml package #:checkers checkers)) + packages))) + + +;;; +;;; Pages. +;;; + +(define (all-packages) + "Return the list of all package objects, sorted by name." + (sort (fold-packages cons '()) + (lambda (p1 p2) + (stringsxml packages)) + ,(packages->sxml (all-packages)) + + (p "Updated " ,(date->string (current-date) "~B ~e, ~Y") + "."))) + + ,(html-page-footer)))) + +(define* (issues-page #:key (checkers %issue-checkers)) + `(html (@ (lang "en")) + ,(html-page-header "Package Issues" #:css "packages.css" #:js "packages.js") + (body + ,(html-page-description) + ,(html-page-links) + + (div (@ (id "content-box")) + (article + (h1 "Package Issues") + + (p "Everybody's got issues! This page lists problems +reported by " + (a (@ (href ,(base-url + "manual/html_node/Invoking-guix-lint.html"))) + (code "guix lint")) ".") + + ,(packages->issue-sxml (all-packages) + #:checkers checkers) (p "Updated " ,(date->string (current-date) "~B ~e, ~Y") "."))) -- cgit v1.2.3