;;; GuixSD website --- GNU's advanced distro website ;;; Copyright © 2013, 2014, 2015, 2016, 2017 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. ;;; ;;; This file is part of GuixSD website. ;;; ;;; GuixSD website is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU Affero General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GuixSD website 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 Affero General Public License for more details. ;;; ;;; You should have received a copy of the GNU Affero General Public License ;;; along with GuixSD website. If not, see . (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 monads) #:use-module (guix grafts) #:use-module (guix gnu-maintenance) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix base32) #:use-module ((guix download) #:select (%mirrors)) #:use-module ((guix build download) #:select (maybe-expand-mirrors)) #:use-module (guix scripts lint) #:use-module (guix scripts challenge) #:use-module (guix scripts substitute) #:use-module (gnu packages) #:use-module (sxml simple) #:use-module (sxml fold) #:use-module (json) #:use-module (web uri) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 i18n) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (texinfo) #:use-module (texinfo html) #:export (%groups package-pages paginated-packages-page issues-page reproducibility-page packages->json)) (define lookup-gnu-package (let ((gnu (delay (official-gnu-packages)))) (lambda (name) "Return the package description for GNU package NAME, or #f." (find (lambda (package) (equal? (gnu-package-name package) name)) (force 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 (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+anchor 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-values (package anchor) (car+cdr package+anchor)) (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) `(div (img (@ (src ,(image-url "status-icons/undefined.png")) (id ,(string-append "icon-" (package-full-name package) "." system)) (class "status-icon") (alt "unknown") (title "unknown"))) (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 ,(list-join (map url (lset-intersection string=? %hydra-supported-systems (package-transitive-supported-systems package))) " "))) (define (package-description-shtml package) "Return a SXML representation of PACKAGE description field with HTML vocabulary." ;; 'texi-fragment->stexi' uses 'call-with-input-string', so make sure ;; those string ports are Unicode-capable. (with-fluids ((%default-port-encoding "UTF-8")) (and=> (package-description package) (compose stexi->shtml texi-fragment->stexi)))) (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"))) "")) "\n" (td (a (@ (id ,anchor) (href ,(source-url package)) (title "Link to the Guix package source code")) ,(package-name package) " " ,(package-version package))) "\n" (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)) "\n" ,(package-description-shtml package) "\n" ,(license package) (a (@ (href ,(package-home-page package)) (title "Link to the package's website")) ,(package-home-page package)) ,(patches package) (br) "\n" ,(status package) "\n" ,(if js? (insert-js-call description-ids) ""))) "\n"))) (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->anchors packages) "Return a one-argument procedure that, given package from the PACKAGES list, returns a unique anchor for it. Anchors are assigned such that the package name is the anchor of the latest version of the package; older versions of the package, if any, have an anchor of the form \"PACKAGE-X.Y.Z\"." (define anchor (let ((mapping (fold (lambda (package result) (vhash-cons (package-name package) package result)) vlist-null packages))) (lambda (package) ;; Return the anchor for PACKAGE. (match (vhash-fold* cons '() (package-name package) mapping) ((one) ;; There's only one version of PACKAGE, so use its name as the ;; anchor. (package-name package)) ((several ..1) ;; There are several versions of PACKAGE. (let ((latest (reduce (lambda (v1 v2) (if (version>? v1 v2) v1 v2)) (package-version package) (map package-version several)))) ;; When PACKAGE is the latest version, use its name as the anchor; ;; otherwise use the full NAME-VERSION form. (if (string=? (package-version package) latest) (package-name package) (package-full-name package)))))))) ;; Precompute the package → anchor mapping. (let ((anchors (fold (lambda (package result) (vhash-consq package (anchor package) result)) vlist-null packages))) (lambda (package) (match (vhash-assq package anchors) ((_ . anchor) anchor))))) (define (packages->sxml packages) "Return an SXML table describing PACKAGES." (define package-anchor ;; Assignment of anchors to packages. (packages->anchors packages)) `(div (table (@ (id "packages")) (tr (th "GNU?") (th "Package version") (th "Package details")) ,@(fold-values package->sxml (zip packages (map package-anchor packages)) '() '() (length packages))) (a (@ (href "#content-box") (title "Back to top.") (id "top")) "^"))) (define* (packages->json #:optional (packages (all-packages))) "Return a JSON string representing PACKAGES." (define (package->alist package) `((name . ,(package-name package)) (version . ,(package-version package)) (cpe-name . ,(or (assoc-ref (package-properties package) 'cpe-name) (package-name package))) (cpe-version . ,(or (assoc-ref (package-properties package) 'cpe-version) (package-version package))) (home-page . ,(package-home-page package)))) (scm->json-string (map package->alist packages) #:pretty #t)) (define (number* number) "Return NUMBER correctly formatting according to English conventions." (number->locale-string number 0 (or (false-if-exception (make-locale LC_ALL "en_US.utf8")) (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) '(p "Nothing to declare!") (let ((count (length issues))) `(div ,@(map (match-lambda ((checker report) `(div (@ (class "issue")) (p (@ (class "issue-type")) ,(lint-checker-name checker) ":") (pre ,(string-trim-right report))))) issues))))) (define* (package->issue-sxml package #:key (anchor (package-full-name package)) (checkers %issue-checkers)) "Return an SXML representation of PACKAGE containing all the reports generated by CHECKERS." (let ((issues (package-issues package checkers)) (name (string-append (package-name package) " " (package-version package)))) `(div (@ (class "issues-list")) (h2 (@ (id ,anchor)) ,name (a (@ (class "anchor-link") (href ,(string-append "#" anchor)) (title "Link to this section")) "§")) (p ;; Issue count ,(issue-count->sxml (length issues)) ". " "See " (a (@ (href ,(source-url package))) "package definition") " in Guix source code.") ,(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." (define total (length packages)) (define processed 0) (define (report-progress) (format (current-error-port) "~5,1f% of all the packages linted\r" (* 100. (/ processed total))) (force-output (current-error-port)) (set! processed (+ 1 processed))) (define package-anchor (packages->anchors packages)) `(div ,@(map (lambda (package) (report-progress) (package->issue-sxml package #:anchor (package-anchor package) #:checkers checkers)) packages))) ;;; ;;; Reproducibility issues reported by 'challenge'. ;;; (define %substitute-servers ;; List of remote substitute servers against which we are comparing. '("https://bayfront.guixsd.org")) (define (local-nar-url item) (string-append "https://mirror.hydra.gnu.org/nar/" (basename item))) (define (discrepancy->sxml discrepancy) "Return the HTML for DISCREPANCY." (let ((item (discrepancy-item discrepancy))) `(li (tt ,item) (ol (li (a (@ (href ,(local-nar-url item)))) (tt ,(bytevector->base32-string (discrepancy-local-sha256 discrepancy)))) ,@(map (lambda (narinfo) `(li (a (@ (href ,(uri->string (narinfo-uri narinfo))))) (tt ,(bytevector->base32-string (narinfo-hash->sha256 (narinfo-hash narinfo)))))) (discrepancy-narinfos discrepancy)))))) (define* (package->reproducibility-sxml package discrepancies #:key anchor) "Return an SXML representation of DISCREPANCIES for PACKAGE." (let ((name (string-append (package-name package) " " (package-version package)))) `(div (@ (class "issues-list")) (h2 (@ (id ,anchor)) ,name (a (@ (class "anchor-link") (href ,(string-append "#" anchor)) (title "Link to this section")) "§")) (p ;; Issue count ,@(if discrepancies (list (issue-count->sxml (length discrepancies)) ". ") '("No idea if it's reproducible. ")) "See " (a (@ (href ,(source-url package))) "package definition") " in Guix source code.") ,(and discrepancies `(div (@ (class "issue")) (ul ,@(map discrepancy->sxml discrepancies))))))) (define* (packages->reproducibility-sxml packages #:key (servers %substitute-servers)) "Return an SXML tree representing the discrepancies found in the outputs of PACKAGES on SERVERS." (define total (length packages)) (define package-anchor (packages->anchors packages)) (define valid? (store-lift valid-path?)) (define (one-of lst) (lambda (discrepancy) (member (discrepancy-item discrepancy) lst))) (define (add-package-outputs package mapping) ;; Add PACKAGE to MAPPING, a vhash that maps packages to outputs. (mlet* %store-monad ((drv (package->derivation package)) (outputs -> (match (derivation->output-paths drv) (((_ . outputs) ...) outputs)))) (foldm %store-monad (lambda (output result) (mlet %store-monad ((valid? (valid? output))) (return (if valid? (vhash-consq package output mapping) result)))) mapping outputs))) (mlet* %store-monad ((mapping (foldm %store-monad add-package-outputs vlist-null packages)) (items -> (vlist-fold (lambda (item result) (match item ((_ . output) (cons output result)))) '() mapping)) (result (discrepancies items %substitute-servers))) (define (->sxml package) (let* ((outputs (vhash-foldq* cons '() package mapping)) (discrepancies (and (not (null? outputs)) (filter (one-of outputs) result)))) (package->reproducibility-sxml package discrepancies #:anchor (package-anchor package)))) (let ((considered (vlist-length mapping))) (return `(div "Considered " ,considered " packages out of " ,total ", corresponding to " ,(length items) " " (tt "/gnu/store") " items.\n" "Out of these, " ,(issue-count->sxml (length result)) " were found (" ,(inexact->exact (round (* 100. (/ (length result) (length items))))) "%).\n\n" ,@(map ->sxml packages)))))) ;;; ;;; Pages. ;;; (define %groups ;; List of package groups. (cons "0-9" (map string '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)))) (define (group-file-name group) (guix-url (string-append "packages/" group ".html"))) (define (group-name group) (string-upcase group)) (define (all-packages) "Return the list of all package objects, sorted by name." (sort (fold-packages (lambda (package lst) (cons (or (package-replacement package) package) lst)) '()) (lambda (p1 p2) (string) first string->list package-name) packages)) (letter (filter (lambda (package) (string=? (string-take (package-name package) 1) letter)) packages))))) (define (paginated-packages-page packages grouping) "Return a packages page that contains only content for the subset of PACKAGES that matches GROUPING (either the string '0-9' or a string of one letter)." (packages-page (packages-by-grouping packages grouping) (string-upcase grouping))) (define* (packages-page #:optional (packages (all-packages)) (grouping "All")) `(html (@ (lang "en")) ,(html-page-header "Packages" #:css "packages.css" #:js "packages.js") (body ,(html-page-description) ,(html-page-links) (div (@ (id "content-box")) (article (h1 ,(string-append "Packages [" grouping "]")) (p "GNU Guix provides " ,(number* (fold-packages (lambda (p n) (+ 1 n)) 0)) " packages transparently " (a (@ (href "http://hydra.gnu.org/jobset/gnu/master#tabs-status")) "available as pre-built binaries") ". These pages provide a complete list of the packages. Our " (a (@ (href "http://hydra.gnu.org/jobset/gnu/master")) "continuous integration system") " shows their current build status " "(updated " ,(date->string (current-date) "~B ~e, ~Y") ").") (p "You can browse packages indexed by their first letter.") (ul ,@(map (lambda (group) `(li (@ (id ,(string-append group "-link")) (class "package-index-link")) (a (@ (href ,(group-file-name group))) ,(group-name group)))) %groups)) ,(packages->sxml packages))) ,(html-page-footer)))) (define* (package-pages #:optional (packages (all-packages))) "Return a list of (FILE PAGE) tuples, where each FILE is an HTML file name and PAGE is the corresponding SXML." `(,@(map (lambda (group) (list (string-append group ".html") (paginated-packages-page packages group))) %groups) ;; Note: We do not build the page for grouping "All" because the poor CVS ;; server at gnu.org runs out of memory when it encounters such a big ;; page (!). ("index.html" ,(paginated-packages-page packages "a")))) (define* (issues-page #:key (checkers %issue-checkers)) `(html (@ (lang "en")) ,(html-page-header "Package Issues" #:css "packages.css") (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")) " (" "Updated " ,(date->string (current-date) "~B ~e, ~Y") ").") ,(packages->issue-sxml (all-packages) #:checkers checkers))) ,(html-page-footer)))) (define* (reproducibility-page) `(html (@ (lang "en")) ,(html-page-header "Package Reproducibility" #:css "packages.css") (body ,(html-page-description) ,(html-page-links) (div (@ (id "content-box")) (article (h1 "Package Reproducibility") (p "Which of our packages is not " (a (@ (href "https://reproducible-builds.org")) "reproducible") "? " "This page lists problems reported by " (a (@ (href ,(base-url "manual/html_node/Invoking-guix-challenge.html"))) (code "guix challenge")) " comparing two independent " "build machines (" "Updated " ,(date->string (current-date) "~B ~e, ~Y") ").") ,(parameterize ((%graft? #f)) (with-store store (run-with-store store (packages->reproducibility-sxml (all-packages))))))) ,(html-page-footer)))) ;;; ;;; SXML Components ;;; (define (issue-count->sxml count) "Return and SXML representation of COUNT." `(,(if (> count 0) 'mark 'span) ,(number->string count) ,(if (= count 1) " issue" " issues")))