02/02: website: Add /packages/issues.html page.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix-artwork.

commit da3edd193269fdbdf264aa4362e3f9155649a428
Author: Ludovic Courtès <address@hidden>
Date:   Fri Nov 13 13:56:20 2015 +0100

    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(-)

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)
+          (string<? (package-name p1)
+                    (package-name p2)))))
+
 (define (packages-page)
   `(html (@ (lang "en"))
         ,(html-page-header "Packages" #:css "packages.css" #:js "packages.js")
@@ -287,11 +376,32 @@ description-ids as formal parameters."
                   (a (@ (href "http://hydra.gnu.org/jobset/gnu/master";))
                      "continuous integration system")
                   " shows their current build status.")
-               ,(let ((packages (sort (fold-packages cons '())
-                                      (lambda (p1 p2)
-                                        (string<? (package-name p1)
-                                                  (package-name p2))))))
-                  (packages->sxml 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")
                    ".")))