diff options
Diffstat (limited to 'guix-data-service')
| -rw-r--r-- | guix-data-service/comparison.scm | 122 | ||||
| -rw-r--r-- | guix-data-service/config.scm.in | 35 | ||||
| -rw-r--r-- | guix-data-service/jobs.scm | 11 | ||||
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 90 | ||||
| -rw-r--r-- | guix-data-service/model/derivation.scm | 70 | ||||
| -rw-r--r-- | guix-data-service/model/guix-revision-package.scm | 19 | ||||
| -rw-r--r-- | guix-data-service/model/guix-revision.scm | 39 | ||||
| -rw-r--r-- | guix-data-service/model/package-metadata.scm | 96 | ||||
| -rw-r--r-- | guix-data-service/model/package.scm | 90 | ||||
| -rw-r--r-- | guix-data-service/model/utils.scm | 27 | ||||
| -rw-r--r-- | guix-data-service/web/controller.scm | 96 | ||||
| -rw-r--r-- | guix-data-service/web/render.scm | 127 | ||||
| -rw-r--r-- | guix-data-service/web/server.scm | 45 | ||||
| -rw-r--r-- | guix-data-service/web/sxml.scm | 371 | ||||
| -rw-r--r-- | guix-data-service/web/util.scm | 45 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 246 |
16 files changed, 1529 insertions, 0 deletions
diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm new file mode 100644 index 0000000..4dfd96e --- /dev/null +++ b/guix-data-service/comparison.scm @@ -0,0 +1,122 @@ +(define-module (guix-data-service comparison) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (squee) + #:export (package-data->package-data-vhashes + package-differences-data + package-data-vhashes->new-packages + package-data-vhashes->removed-packages + package-data-version-changes + package-data-other-changes)) + +(define (package-differences-data conn base_guix_revision_id target_guix_revision_id) + (define query + "WITH base_packages AS ( + SELECT packages.* FROM packages INNER JOIN guix_revision_packages ON packages.id = guix_revision_packages.package_id WHERE revision_id = $1 +), target_packages AS ( + SELECT packages.* FROM packages INNER JOIN guix_revision_packages ON packages.id = guix_revision_packages.package_id WHERE revision_id = $2 +) +SELECT base_packages.name, base_packages.version, base_packages.package_metadata_id, base_packages.derivation_id, target_packages.name, target_packages.version, target_packages.package_metadata_id, target_packages.derivation_id +FROM base_packages +FULL OUTER JOIN target_packages ON base_packages.name = target_packages.name AND base_packages.version = target_packages.version +WHERE (base_packages.id IS NULL OR target_packages.id IS NULL OR base_packages.id != target_packages.id) +ORDER BY base_packages.name, base_packages.version, target_packages.name, target_packages.version") + + (exec-query conn query (list base_guix_revision_id target_guix_revision_id))) + +(define (package-data->package-data-vhashes package-data) + (define (add-data-to-vhash data vhash) + (let ((key (first data))) + (if (string-null? key) + vhash + (vhash-cons key + (drop data 1) + vhash)))) + + (apply values + (fold (lambda (row result) + (let-values (((base-row-part target-row-part) (split-at row 4))) + (match result + ((base-package-data target-package-data) + (list (add-data-to-vhash base-row-part base-package-data) + (add-data-to-vhash target-row-part target-package-data)))))) + (list vlist-null vlist-null) + package-data))) + +(define (package-data-vhash->package-name-and-version-vhash vhash) + (vhash-fold (lambda (name details result) + (vhash-cons (cons name (first details)) + (cdr details) + result)) + vlist-null + vhash)) + +(define (package-data-vhashes->new-packages base-packages-vhash target-packages-vhash) + (vlist->list + (vlist-filter (match-lambda + ((name . details) + (not (vhash-assoc name base-packages-vhash)))) + target-packages-vhash))) + +(define (package-data-vhashes->removed-packages base-packages-vhash target-packages-vhash) + (vlist->list + (vlist-filter (match-lambda + ((name . details) + (not (vhash-assoc name target-packages-vhash)))) + base-packages-vhash))) + +(define (package-data-vhash->package-versions-vhash package-data-vhash) + (vhash-fold (lambda (name details result) + (let ((version (first details)) + (known-versions (vhash-assoc name result))) + (if known-versions + (vhash-cons name + (cons version known-versions) + (vhash-delete name result)) + (vhash-cons name + (list version) + result)))) + vlist-null + package-data-vhash)) + +(define (package-data-version-changes base-packages-vhash target-packages-vhash) + (let ((base-versions (package-data-vhash->package-versions-vhash + base-packages-vhash)) + (target-versions (package-data-vhash->package-versions-vhash + target-packages-vhash))) + (vhash-fold (lambda (name target-versions result) + (let ((base-versions (and=> (vhash-assoc name base-versions) + cdr))) + (if base-versions + (begin + (if (equal? base-versions target-versions) + result + `((,name . ((base . ,base-versions) + (target . ,target-versions))) + ,@result))) + result))) + '() + target-versions))) + +(define (package-data-other-changes base-packages-vhash target-packages-vhash) + (define base-package-details-by-name-and-version + (package-data-vhash->package-name-and-version-vhash base-packages-vhash)) + + (define target-package-details-by-name-and-version + (package-data-vhash->package-name-and-version-vhash target-packages-vhash)) + + (vhash-fold (lambda (name-and-version target-details result) + (let ((base-packages-entry + (vhash-assoc name-and-version base-package-details-by-name-and-version))) + (if base-packages-entry + (let ((base-details (cdr base-packages-entry))) + (if (equal? base-details target-details) + result + `((,name-and-version . ((base . ,base-details) + (target . ,target-details))) + ,@result))) + result))) + '() + target-package-details-by-name-and-version)) diff --git a/guix-data-service/config.scm.in b/guix-data-service/config.scm.in new file mode 100644 index 0000000..d2e699b --- /dev/null +++ b/guix-data-service/config.scm.in @@ -0,0 +1,35 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service config) + #:export (%config)) + +(define %config + (let ((config + ;; Try to find the "assets" directory relative to the executable + ;; first. This is useful when using "pre-inst-env". + `((assets-dir . ,(let ((maybe-dir + (string-append (getcwd) "/assets"))) + (if (file-exists? maybe-dir) + maybe-dir + ;; TODO: use @assetsdir@ variable here + "@prefix@/share/guix-data-service/assets"))) + (host . "localhost") + (port . 8765)))) + (lambda (key) + (assoc-ref config key)))) diff --git a/guix-data-service/jobs.scm b/guix-data-service/jobs.scm new file mode 100644 index 0000000..0d5c266 --- /dev/null +++ b/guix-data-service/jobs.scm @@ -0,0 +1,11 @@ +(define-module (guix-data-service jobs) + #:use-module (ice-9 match) + #:use-module (guix-data-service jobs load-new-guix-revision) + #:export (process-jobs)) + +(define (process-jobs conn) + (match (process-next-load-new-guix-revision-job conn) + (#f (begin (simple-format #t "Waiting for new jobs...") + (sleep 60) + (process-jobs conn))) + (_ (process-jobs conn)))) diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm new file mode 100644 index 0000000..8aeef51 --- /dev/null +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -0,0 +1,90 @@ +(define-module (guix-data-service jobs load-new-guix-revision) + #:use-module (ice-9 match) + #:use-module (squee) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix channels) + #:use-module (guix inferior) + #:use-module (guix profiles) + #:use-module (guix derivations) + #:use-module (guix-data-service model package) + #:use-module (guix-data-service model guix-revision) + #:use-module (guix-data-service model guix-revision-package) + #:use-module (guix-data-service model package-metadata) + #:use-module (guix-data-service model derivation) + #:export (process-next-load-new-guix-revision-job)) + +(define (inferior-guix->package-ids store conn inf) + (let* ((packages (inferior-packages inf)) + (packages-metadata-ids + (inferior-packages->package-metadata-ids conn packages)) + (packages-derivation-ids + (inferior-packages->derivation-ids store conn packages))) + + (inferior-packages->package-ids + conn packages packages-metadata-ids packages-derivation-ids))) + +(define (channel->manifest-store-item store channel) + (define (build-and-get-output-path store profile-derv) + (run-with-store store + (mbegin %store-monad + (built-derivations (list profile-derv)) + (return (derivation->output-path profile-derv))))) + + (let ((instances (latest-channel-instances store (list channel)))) + (run-with-store store + (mlet* %store-monad ((manifest (channel-instances->manifest instances)) + (derv (profile-derivation manifest))) + ((store-lift build-and-get-output-path) derv))))) + +(define (channel->guix-store-item store channel) + (dirname + (readlink + (string-append (channel->manifest-store-item store channel) + "/bin")))) + +(define (extract-information-from store conn url commit store_path) + (let ((inf (open-inferior store_path))) + (inferior-eval '(use-modules (guix grafts)) inf) + (inferior-eval '(%graft? #f) inf) + + (let ((package-ids (inferior-guix->package-ids store conn inf))) + (exec-query conn "BEGIN") + + (let ((guix-revision-id + (insert-guix-revision conn url commit store_path))) + (insert-guix-revision-packages conn guix-revision-id package-ids))) + + (exec-query conn "COMMIT") + + (close-inferior inf))) + +(define (load-new-guix-revision conn url commit) + (if (guix-revision-exists? conn url commit) + #t + (with-store store + (let ((store-item (channel->guix-store-item + store + (channel (name 'guix) + (url url) + (commit commit))))) + (extract-information-from store conn url commit store-item))))) + +(define (process-next-load-new-guix-revision-job conn) + (let ((next + (exec-query + conn + "SELECT * FROM load_new_guix_revision_jobs ORDER BY id ASC LIMIT 1"))) + (match next + (((id url commit)) + (begin + (simple-format #t "Processing job ~A (url: ~A, commit: ~A)\n\n" + id url commit) + (load-new-guix-revision conn url commit) + (exec-query + conn + (string-append "DELETE FROM load_new_guix_revision_jobs WHERE id = '" + id + "'")))) + (_ #f)))) + diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm new file mode 100644 index 0000000..0dfa2af --- /dev/null +++ b/guix-data-service/model/derivation.scm @@ -0,0 +1,70 @@ +(define-module (guix-data-service model derivation) + #:use-module (srfi srfi-1) + #:use-module (ice-9 vlist) + #:use-module (squee) + #:use-module (guix inferior) + #:use-module (guix derivations) + #:use-module (guix-data-service model utils) + #:export (select-existing-derivations + insert-into-derivations + inferior-packages->derivation-ids)) + +(define (select-existing-derivations file-names) + (string-append "SELECT id, file_name " + "FROM derivations " + "WHERE file_name IN " + "(" (string-join (map (lambda (file-name) + (simple-format #f "'~A'" file-name)) + file-names) + ",") + ");")) + +(define (insert-into-derivations file-names) + (string-append "INSERT INTO derivations (file_name) VALUES " + (string-join + (map + (lambda (file-name) + (simple-format #f "('~A')" file-name)) + file-names) + ",") + " RETURNING id" + ";")) + +(define (inferior-packages->derivation-ids store conn inferior-packages) + (let* ((package-derivation-file-names (map (lambda (package) + (derivation-file-name + (inferior-package-derivation + store package))) + inferior-packages)) + + (existing-derivation-entries (exec-query->vhash + conn + (select-existing-derivations + package-derivation-file-names) + second ;; file_name + first)) ;; id + + (missing-derivation-file-names + (filter (lambda (file-name) + (not (vhash-assoc file-name + existing-derivation-entries))) + package-derivation-file-names)) + (new-derivation-entries + (if (null? missing-derivation-file-names) + '() + (map car + (exec-query + conn + (insert-into-derivations + missing-derivation-file-names))))) + (new-entries-id-lookup-vhash + (two-lists->vhash missing-derivation-file-names + new-derivation-entries))) + (map (lambda (derivation-file-name) + (cdr + (or (vhash-assoc derivation-file-name + existing-derivation-entries) + (vhash-assoc derivation-file-name + new-entries-id-lookup-vhash) + (error "missing derivation id")))) + package-derivation-file-names))) diff --git a/guix-data-service/model/guix-revision-package.scm b/guix-data-service/model/guix-revision-package.scm new file mode 100644 index 0000000..2f710a4 --- /dev/null +++ b/guix-data-service/model/guix-revision-package.scm @@ -0,0 +1,19 @@ +(define-module (guix-data-service model guix-revision-package) + #:use-module (squee) + #:export (insert-guix-revision-packages)) + +(define (insert-guix-revision-packages conn guix-revision-id package-ids) + (define insert + (string-append "INSERT INTO guix_revision_packages " + "(revision_id, package_id) " + "VALUES " + (string-join (map (lambda (package-id) + (simple-format + #f "(~A, ~A)" + guix-revision-id + package-id)) + package-ids) + ", ") + ";")) + + (exec-query conn insert)) diff --git a/guix-data-service/model/guix-revision.scm b/guix-data-service/model/guix-revision.scm new file mode 100644 index 0000000..d9a8976 --- /dev/null +++ b/guix-data-service/model/guix-revision.scm @@ -0,0 +1,39 @@ +(define-module (guix-data-service model guix-revision) + #:use-module (ice-9 match) + #:use-module (squee) + #:export (most-recent-n-guix-revisions + commit->revision-id + insert-guix-revision + guix-revision-exists?)) + +(define (most-recent-n-guix-revisions conn n) + (exec-query conn "SELECT * FROM guix_revisions ORDER BY id DESC LIMIT 10")) + +(define (commit->revision-id conn commit) + (match (exec-query + conn "SELECT id FROM guix_revisions WHERE commit = $1 LIMIT 1" + (list commit)) + (((id)) + id))) + +(define (insert-guix-revision conn url commit store_path) + (define insert + (string-append "INSERT INTO guix_revisions " + "(url, commit, store_path) VALUES " + "('" url "', '" + commit "', '" + store_path "') " + "RETURNING id;")) + + (map car (exec-query conn insert))) + +(define (guix-revision-exists? conn url commit) + (define query + (string-append "SELECT EXISTS(" + "SELECT 1 FROM guix_revisions WHERE url = '" url "' " + "AND commit = '" commit "')" + ";")) + + (let ((result (caar + (exec-query conn query)))) + (string=? result "t"))) diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm new file mode 100644 index 0000000..429538b --- /dev/null +++ b/guix-data-service/model/package-metadata.scm @@ -0,0 +1,96 @@ +(define-module (guix-data-service model package-metadata) + #:use-module (srfi srfi-1) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (squee) + #:use-module (gcrypt hash) + #:use-module (rnrs bytevectors) + #:use-module (guix base16) + #:use-module (guix inferior) + #:use-module (guix-data-service model utils) + #:export (select-package-metadata + insert-package-metadata + inferior-packages->package-metadata-ids)) + +(define (select-package-metadata hashes) + (string-append "SELECT id, sha1_hash " + "FROM package_metadata " + "WHERE sha1_hash IN (" + (string-join (map (lambda (hash) + (simple-format #f "'~A'" hash)) + hashes) + ",") + ");")) + +(define (insert-package-metadata metadata-rows) + (string-append "INSERT INTO package_metadata " + "(sha1_hash, synopsis, description, home_page) " + "VALUES " + (string-join + (map (match-lambda + ((sha1_hash synopsis description home_page) + (string-append + "('" sha1_hash "'," + (value->quoted-string-or-null synopsis) "," + (value->quoted-string-or-null description) "," + (value->quoted-string-or-null home_page) ")"))) + metadata-rows) + ",") + " RETURNING id" + ";")) + + +(define (inferior-packages->package-metadata-ids conn packages) + (define package-metadata + (map (lambda (package) + (let ((data (list (inferior-package-synopsis package) + (inferior-package-description package) + (inferior-package-home-page package)))) + `(,(bytevector->base16-string + (sha1 (string->utf8 + (string-join + (map (lambda (d) + (cond + ((string? d) d) + ((boolean? d) (simple-format #f "~A" d)) + (else d))) + data) + ":")))) + ,@data))) + packages)) + + (define package-metadata-hashes + (map first package-metadata)) + + (let* ((existing-package-metadata-entries + (exec-query->vhash conn + (select-package-metadata + package-metadata-hashes) + second ;; sha1_hash + first)) ;; id)) + (missing-package-metadata-entries + (delete-duplicates + (filter (lambda (metadata) + (not (vhash-assoc (first metadata) + existing-package-metadata-entries))) + package-metadata))) + (new-package-metadata-entries + (if (null? missing-package-metadata-entries) + '() + (map car (exec-query conn + (insert-package-metadata + missing-package-metadata-entries))))) + (new-entries-id-lookup-vhash + (two-lists->vhash (map first missing-package-metadata-entries) + new-package-metadata-entries))) + + (map (lambda (sha1-hash) + (cdr + (or (vhash-assoc sha1-hash + existing-package-metadata-entries) + (vhash-assoc sha1-hash + new-entries-id-lookup-vhash) + (begin + sha1-hash + (error "missing package-metadata entry"))))) + package-metadata-hashes))) diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm new file mode 100644 index 0000000..c90fb04 --- /dev/null +++ b/guix-data-service/model/package.scm @@ -0,0 +1,90 @@ +(define-module (guix-data-service model package) + #:use-module (srfi srfi-1) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (squee) + #:use-module (guix inferior) + #:use-module (guix-data-service model utils) + #:export (select-existing-package-entries + insert-into-package-entries + inferior-packages->package-ids)) + +(define (select-existing-package-entries package-entries) + (string-append "SELECT id, packages.name, packages.version, " + "packages.package_metadata_id, packages.derivation_id " + "FROM packages " + "JOIN (VALUES " + (string-join (map (lambda (package-entry) + (apply + simple-format + #f "('~A', '~A', ~A, ~A)" + package-entry)) + package-entries) + ", ") + ") AS vals (name, version, package_metadata_id, derivation_id) " + "ON packages.name = vals.name AND " + "packages.version = vals.version AND " + "packages.package_metadata_id = vals.package_metadata_id AND " + "packages.derivation_id = vals.derivation_id" + ";")) + +(define (insert-into-package-entries package-entries) + (string-append "INSERT INTO packages " + "(name, version, package_metadata_id, derivation_id) VALUES " + (string-join + (map + (match-lambda + ((name version package_metadata_id derivation_id) + (simple-format #f "('~A', '~A', ~A, ~A)" + name + version + package_metadata_id + derivation_id))) + package-entries) + ",") + " RETURNING id" + ";")) + +(define (inferior-packages->package-ids conn packages metadata-ids derivation-ids) + (define package-entries + (map (lambda (package metadata-id derivation-id) + (list (inferior-package-name package) + (inferior-package-version package) + metadata-id + derivation-id)) + packages + metadata-ids + derivation-ids)) + + (let* ((existing-package-entry-ids + (exec-query->vhash conn + (select-existing-package-entries package-entries) + ;; name, version, package_metadata_id and + ;; derivation_id + cdr + first)) ;;id + (missing-package-entries + (filter (lambda (package-entry) + (not (vhash-assoc package-entry + existing-package-entry-ids))) + package-entries)) + (new-package-entry-ids + (if (null? missing-package-entries) + '() + (map car + (exec-query + conn + (insert-into-package-entries + missing-package-entries))))) + (new-entries-id-lookup-vhash + (two-lists->vhash missing-package-entries + new-package-entry-ids))) + + (map (lambda (package-entry) + (cdr + (or (vhash-assoc package-entry + existing-package-entry-ids) + (vhash-assoc package-entry + new-entries-id-lookup-vhash) + (error "missing package entry")))) + package-entries))) diff --git a/guix-data-service/model/utils.scm b/guix-data-service/model/utils.scm new file mode 100644 index 0000000..df2acd9 --- /dev/null +++ b/guix-data-service/model/utils.scm @@ -0,0 +1,27 @@ +(define-module (guix-data-service model utils) + #:use-module (srfi srfi-1) + #:use-module (ice-9 vlist) + #:use-module (squee) + #:export (value->quoted-string-or-null + exec-query->vhash + two-lists->vhash)) + +(define (value->quoted-string-or-null value) + (if (string? value) + (string-append "$STR$" value "$STR$") + "NULL")) + +(define (exec-query->vhash conn query field-function value-function) + (fold (lambda (row result) + (vhash-cons (field-function row) + (value-function row) + result)) + vlist-null + (exec-query conn query))) + +(define (two-lists->vhash l1 l2) + (fold (lambda (key value result) + (vhash-cons key value result)) + vlist-null + l1 + l2)) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm new file mode 100644 index 0000000..1d7bd72 --- /dev/null +++ b/guix-data-service/web/controller.scm @@ -0,0 +1,96 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service web controller) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (web request) + #:use-module (web uri) + #:use-module (squee) + #:use-module (guix-data-service comparison) + #:use-module (guix-data-service model guix-revision) + #:use-module (guix-data-service web render) + #:use-module (guix-data-service web util) + #:use-module (guix-data-service web view html) + #:export (controller)) + +(define-syntax-rule (-> target functions ...) + (fold (lambda (f val) (and=> val f)) + target + (list functions ...))) + +(define (render-with-error-handling page message) + (apply render-html (page)) + ;; (catch #t + ;; (lambda () + ;; (receive (sxml headers) + ;; (pretty-print (page)) + ;; (render-html sxml headers))) + ;; (lambda (key . args) + ;; (format #t "ERROR: ~a ~a\n" + ;; key args) + ;; (render-html (error-page message)))) + ) + +(define (controller request body) + (define conn (connect-to-postgres-paramstring "dbname=guix_data_service")) + + (match-lambda + ((GET) + (apply render-html (index (most-recent-n-guix-revisions conn 10)))) + ((GET "compare") + (let ((base-commit (-> request + request-uri + uri-query + parse-query-string + (cut assoc-ref <> "base_commit"))) + (target-commit (-> request + request-uri + uri-query + parse-query-string + (cut assoc-ref <> "target_commit")))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-data->package-data-vhashes + (package-differences-data conn + (commit->revision-id conn base-commit) + (commit->revision-id conn target-commit))))) + (let* ((new-packages + (package-data-vhashes->new-packages base-packages-vhash + target-packages-vhash)) + (removed-packages + (package-data-vhashes->removed-packages base-packages-vhash + target-packages-vhash)) + (version-changes + (package-data-version-changes base-packages-vhash + target-packages-vhash)) + (other-changes + (package-data-other-changes base-packages-vhash + target-packages-vhash))) + (apply render-html + (compare base-commit + target-commit + new-packages + removed-packages + version-changes + other-changes)))))) + ((GET path ...) + (render-static-asset request)))) diff --git a/guix-data-service/web/render.scm b/guix-data-service/web/render.scm new file mode 100644 index 0000000..94cbf55 --- /dev/null +++ b/guix-data-service/web/render.scm @@ -0,0 +1,127 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;; This code was snarfed from David Thompson's guix-web. + +(define-module (guix-data-service web render) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (ice-9 binary-ports) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (json) + #:use-module (guix-data-service config) + #:use-module (guix-data-service web sxml) + #:use-module (guix-data-service web util) + #:export (render-static-asset + render-html + render-json + not-found + unprocessable-entity + created + redirect)) + +(define file-mime-types + '(("css" . (text/css)) + ("js" . (text/javascript)) + ("svg" . (image/svg+xml)) + ("png" . (image/png)) + ("gif" . (image/gif)) + ("woff" . (application/font-woff)) + ("ttf" . (application/octet-stream)) + ("html" . (text/html)))) + +(define (render-static-asset request) + (render-static-file (%config 'assets-dir) request)) + +(define %not-slash + (char-set-complement (char-set #\/))) + +(define (render-static-file root request) + (define path + (uri-path (request-uri request))) + + (define failure + (not-found (build-uri 'http + #:host (%config 'host) + #:port (%config 'port) + #:path path))) + + (let ((file-name (string-append root "/" path))) + (if (not (any (cut string-contains <> "..") + (string-tokenize path %not-slash))) + (let* ((stat (stat file-name #f)) + (modified (and stat + (make-time time-utc 0 (stat:mtime stat))))) + (define (send-file) + (list `((content-type + . ,(assoc-ref file-mime-types + (file-extension file-name))) + (last-modified . ,(time-utc->date modified))) + (call-with-input-file file-name get-bytevector-all))) + + (if (and stat (not (eq? 'directory (stat:type stat)))) + (cond ((assoc-ref (request-headers request) 'if-modified-since) + => + (lambda (client-date) + (if (time>? modified (date->time-utc client-date)) + (send-file) + (list (build-response #:code 304) ;"Not Modified" + #f)))) + (else + (send-file))) + failure)) + failure))) + +(define* (render-html #:key sxml (extra-headers '())) + (list (append extra-headers + '((content-type . (text/html)))) + (lambda (port) + (sxml->html sxml port)))) + +(define (render-json json) + (list '((content-type . (application/json))) + (lambda (port) + (scm->json json port)))) + +(define (not-found uri) + (list (build-response #:code 404) + (string-append "Resource not found: " (uri->string uri)))) + +(define (unprocessable-entity) + (list (build-response #:code 422) + "")) + +(define (created) + (list (build-response #:code 201) + "")) + +(define (redirect path) + (let ((uri (build-uri 'http + #:host (%config 'host) + #:port (%config 'port) + #:path (string-append + "/" (encode-and-join-uri-path path))))) + (list (build-response + #:code 301 + #:headers `((content-type . (text/html)) + (location . ,uri))) + (format #f "Redirect to ~a" (uri->string uri))))) diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm new file mode 100644 index 0000000..2077629 --- /dev/null +++ b/guix-data-service/web/server.scm @@ -0,0 +1,45 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service web server) + #:use-module (srfi srfi-1) + #:use-module (web http) + #:use-module (web request) + #:use-module (web uri) + #:use-module (fibers web server) + #:use-module (guix-data-service web controller) + #:use-module (guix-data-service web util) + #:export (start-guix-data-service-web-server)) + +(define (run-controller controller request body) + ((controller request body) + (cons (request-method request) + (request-path-components request)))) + +(define (handler request body controller) + (format #t "~a ~a\n" + (request-method request) + (uri-path (request-uri request))) + (apply values + (run-controller controller request body))) + +(define (start-guix-data-service-web-server port) + (run-server (lambda (request body) + (handler request body controller)) + #:addr INADDR_ANY + #:port port)) diff --git a/guix-data-service/web/sxml.scm b/guix-data-service/web/sxml.scm new file mode 100644 index 0000000..468b81f --- /dev/null +++ b/guix-data-service/web/sxml.scm @@ -0,0 +1,371 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; SXML to HTML conversion. +;; +;;; Code: + +(define-module (guix-data-service web sxml) + #:use-module (sxml simple) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 hash-table) + #:export (sxml->html)) + +(define %self-closing-tags + '(area + base + br + col + command + embed + hr + img + input + keygen + link + meta + param + source + track + wbr)) + +(define (self-closing-tag? tag) + "Return #t if TAG is self-closing." + (pair? (memq tag %self-closing-tags))) + +(define %escape-chars + (alist->hash-table + '((#\" . "quot") + (#\& . "amp") + (#\' . "apos") + (#\< . "lt") + (#\> . "gt") + (#\¡ . "iexcl") + (#\¢ . "cent") + (#\£ . "pound") + (#\¤ . "curren") + (#\¥ . "yen") + (#\¦ . "brvbar") + (#\§ . "sect") + (#\¨ . "uml") + (#\© . "copy") + (#\ª . "ordf") + (#\« . "laquo") + (#\¬ . "not") + (#\® . "reg") + (#\¯ . "macr") + (#\° . "deg") + (#\± . "plusmn") + (#\² . "sup2") + (#\³ . "sup3") + (#\´ . "acute") + (#\µ . "micro") + (#\¶ . "para") + (#\· . "middot") + (#\¸ . "cedil") + (#\¹ . "sup1") + (#\º . "ordm") + (#\» . "raquo") + (#\¼ . "frac14") + (#\½ . "frac12") + (#\¾ . "frac34") + (#\¿ . "iquest") + (#\À . "Agrave") + (#\Á . "Aacute") + (#\ . "Acirc") + (#\à . "Atilde") + (#\Ä . "Auml") + (#\Å . "Aring") + (#\Æ . "AElig") + (#\Ç . "Ccedil") + (#\È . "Egrave") + (#\É . "Eacute") + (#\Ê . "Ecirc") + (#\Ë . "Euml") + (#\Ì . "Igrave") + (#\Í . "Iacute") + (#\Î . "Icirc") + (#\Ï . "Iuml") + (#\Ð . "ETH") + (#\Ñ . "Ntilde") + (#\Ò . "Ograve") + (#\Ó . "Oacute") + (#\Ô . "Ocirc") + (#\Õ . "Otilde") + (#\Ö . "Ouml") + (#\× . "times") + (#\Ø . "Oslash") + (#\Ù . "Ugrave") + (#\Ú . "Uacute") + (#\Û . "Ucirc") + (#\Ü . "Uuml") + (#\Ý . "Yacute") + (#\Þ . "THORN") + (#\ß . "szlig") + (#\à . "agrave") + (#\á . "aacute") + (#\â . "acirc") + (#\ã . "atilde") + (#\ä . "auml") + (#\å . "aring") + (#\æ . "aelig") + (#\ç . "ccedil") + (#\è . "egrave") + (#\é . "eacute") + (#\ê . "ecirc") + (#\ë . "euml") + (#\ì . "igrave") + (#\í . "iacute") + (#\î . "icirc") + (#\ï . "iuml") + (#\ð . "eth") + (#\ñ . "ntilde") + (#\ò . "ograve") + (#\ó . "oacute") + (#\ô . "ocirc") + (#\õ . "otilde") + (#\ö . "ouml") + (#\÷ . "divide") + (#\ø . "oslash") + (#\ù . "ugrave") + (#\ú . "uacute") + (#\û . "ucirc") + (#\ü . "uuml") + (#\ý . "yacute") + (#\þ . "thorn") + (#\ÿ . "yuml") + (#\Œ . "OElig") + (#\œ . "oelig") + (#\Š . "Scaron") + (#\š . "scaron") + (#\Ÿ . "Yuml") + (#\ƒ . "fnof") + (#\ˆ . "circ") + (#\˜ . "tilde") + (#\Α . "Alpha") + (#\Β . "Beta") + (#\Γ . "Gamma") + (#\Δ . "Delta") + (#\Ε . "Epsilon") + (#\Ζ . "Zeta") + (#\Η . "Eta") + (#\Θ . "Theta") + (#\Ι . "Iota") + (#\Κ . "Kappa") + (#\Λ . "Lambda") + (#\Μ . "Mu") + (#\Ν . "Nu") + (#\Ξ . "Xi") + (#\Ο . "Omicron") + (#\Π . "Pi") + (#\Ρ . "Rho") + (#\Σ . "Sigma") + (#\Τ . "Tau") + (#\Υ . "Upsilon") + (#\Φ . "Phi") + (#\Χ . "Chi") + (#\Ψ . "Psi") + (#\Ω . "Omega") + (#\α . "alpha") + (#\β . "beta") + (#\γ . "gamma") + (#\δ . "delta") + (#\ε . "epsilon") + (#\ζ . "zeta") + (#\η . "eta") + (#\θ . "theta") + (#\ι . "iota") + (#\κ . "kappa") + (#\λ . "lambda") + (#\μ . "mu") + (#\ν . "nu") + (#\ξ . "xi") + (#\ο . "omicron") + (#\π . "pi") + (#\ρ . "rho") + (#\ς . "sigmaf") + (#\σ . "sigma") + (#\τ . "tau") + (#\υ . "upsilon") + (#\φ . "phi") + (#\χ . "chi") + (#\ψ . "psi") + (#\ω . "omega") + (#\ϑ . "thetasym") + (#\ϒ . "upsih") + (#\ϖ . "piv") + (#\ . "ensp") + (#\ . "emsp") + (#\ . "thinsp") + (#\– . "ndash") + (#\— . "mdash") + (#\‘ . "lsquo") + (#\’ . "rsquo") + (#\‚ . "sbquo") + (#\“ . "ldquo") + (#\” . "rdquo") + (#\„ . "bdquo") + (#\† . "dagger") + (#\‡ . "Dagger") + (#\• . "bull") + (#\… . "hellip") + (#\‰ . "permil") + (#\′ . "prime") + (#\″ . "Prime") + (#\‹ . "lsaquo") + (#\› . "rsaquo") + (#\‾ . "oline") + (#\⁄ . "frasl") + (#\€ . "euro") + (#\ℑ . "image") + (#\℘ . "weierp") + (#\ℜ . "real") + (#\™ . "trade") + (#\ℵ . "alefsym") + (#\← . "larr") + (#\↑ . "uarr") + (#\→ . "rarr") + (#\↓ . "darr") + (#\↔ . "harr") + (#\↵ . "crarr") + (#\⇐ . "lArr") + (#\⇑ . "uArr") + (#\⇒ . "rArr") + (#\⇓ . "dArr") + (#\⇔ . "hArr") + (#\∀ . "forall") + (#\∂ . "part") + (#\∃ . "exist") + (#\∅ . "empty") + (#\∇ . "nabla") + (#\∈ . "isin") + (#\∉ . "notin") + (#\∋ . "ni") + (#\∏ . "prod") + (#\∑ . "sum") + (#\− . "minus") + (#\∗ . "lowast") + (#\√ . "radic") + (#\∝ . "prop") + (#\∞ . "infin") + (#\∠ . "ang") + (#\∧ . "and") + (#\∨ . "or") + (#\∩ . "cap") + (#\∪ . "cup") + (#\∫ . "int") + (#\∴ . "there4") + (#\∼ . "sim") + (#\≅ . "cong") + (#\≈ . "asymp") + (#\≠ . "ne") + (#\≡ . "equiv") + (#\≤ . "le") + (#\≥ . "ge") + (#\⊂ . "sub") + (#\⊃ . "sup") + (#\⊄ . "nsub") + (#\⊆ . "sube") + (#\⊇ . "supe") + (#\⊕ . "oplus") + (#\⊗ . "otimes") + (#\⊥ . "perp") + (#\⋅ . "sdot") + (#\⋮ . "vellip") + (#\⌈ . "lceil") + (#\⌉ . "rceil") + (#\⌊ . "lfloor") + (#\⌋ . "rfloor") + (#\〈 . "lang") + (#\〉 . "rang") + (#\◊ . "loz") + (#\♠ . "spades") + (#\♣ . "clubs") + (#\♥ . "hearts") + (#\♦ . "diams")))) + +(define (string->escaped-html s port) + "Write the HTML escaped form of S to PORT." + (define (escape c) + (let ((escaped (hash-ref %escape-chars c))) + (if escaped + (format port "&~a;" escaped) + (display c port)))) + (string-for-each escape s)) + +(define (object->escaped-html obj port) + "Write the HTML escaped form of OBJ to PORT." + (string->escaped-html + (call-with-output-string (cut display obj <>)) + port)) + +(define (attribute-value->html value port) + "Write the HTML escaped form of VALUE to PORT." + (if (string? value) + (string->escaped-html value port) + (object->escaped-html value port))) + +(define (attribute->html attr value port) + "Write ATTR and VALUE to PORT." + (format port "~a=\"" attr) + (attribute-value->html value port) + (display #\" port)) + +(define (element->html tag attrs body port) + "Write the HTML TAG to PORT, where TAG has the attributes in the +list ATTRS and the child nodes in BODY." + (format port "<~a" tag) + (for-each (match-lambda + ((attr value) + (display #\space port) + (attribute->html attr value port))) + attrs) + (if (and (null? body) (self-closing-tag? tag)) + (display " />" port) + (begin + (display #\> port) + (for-each (cut sxml->html <> port) body) + (format port "</~a>" tag)))) + +(define (doctype->html doctype port) + (format port "<!DOCTYPE ~a>" doctype)) + +(define* (sxml->html tree #:optional (port (current-output-port))) + "Write the serialized HTML form of TREE to PORT." + (match tree + (() *unspecified*) + (('doctype type) + (doctype->html type port)) + ;; Unescaped, raw HTML output + (('raw html) + (display html port)) + (((? symbol? tag) ('@ attrs ...) body ...) + (element->html tag attrs body port)) + (((? symbol? tag) body ...) + (element->html tag '() body port)) + ((nodes ...) + (for-each (cut sxml->html <> port) nodes)) + ((? string? text) + (string->escaped-html text port)) + ;; Render arbitrary Scheme objects, too. + (obj (object->escaped-html obj port)))) diff --git a/guix-data-service/web/util.scm b/guix-data-service/web/util.scm new file mode 100644 index 0000000..1938890 --- /dev/null +++ b/guix-data-service/web/util.scm @@ -0,0 +1,45 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service web util) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (web request) + #:use-module (web uri) + #:export (parse-query-string + request-path-components + file-extension + directory?)) + +(define (parse-query-string query) + "Parse and decode the URI query string QUERY and return an alist." + (let lp ((lst (map uri-decode (string-split query (char-set #\& #\=))))) + (match lst + ((key value . rest) + (cons (cons key value) (lp rest))) + (() '())))) + +(define (request-path-components request) + (split-and-decode-uri-path (uri-path (request-uri request)))) + +(define (file-extension file-name) + (last (string-split file-name #\.))) + +(define (directory? filename) + (string=? filename (dirname filename))) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm new file mode 100644 index 0000000..9699ef6 --- /dev/null +++ b/guix-data-service/web/view/html.scm @@ -0,0 +1,246 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service web view html) + #:use-module (guix-data-service config) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:export (index + compare + unknown + error-page)) + +(define* (header) + `(nav + (@ (id "header") (class "navbar navbar-default")) + (div + (@ (class "container-fluid")) + (div + (@ (class "navbar-header")) + (div (@ (class "navbar-brand")) + (a (@ (href "/") (class "logo")))))))) + +(define* (layout #:key + (head '()) + (body '()) + (title "Guix Data Service") + (extra-headers '())) + `(#:sxml ((doctype "html") + (html + (head + (title ,title) + (meta (@ (http-equiv "Content-Type") + (content "text/html; charset=UTF-8"))) + (meta (@ (http-equiv "Content-Language") (content "en"))) + (meta (@ (name "author") (content "Christopher Baines"))) + (meta (@ (name "viewport") + (content "width=device-width, initial-scale=1"))) + (link + (@ (rel "stylesheet") + (media "screen") + (type "text/css") + (href "/css/reset.css"))) + (link + (@ (rel "stylesheet") + (media "screen") + (type "text/css") + (href "/css/bootstrap.css"))) + ,@head + (link + (@ (rel "stylesheet") + (media "screen") + (type "text/css") + (href "/css/screen.css")))) + (body ,@body + (footer + (p "Copyright © 2016—2019 by the GNU Guix community." + (br) + "Now with even more " (span (@ (class "lambda")) "λ") "! ") + (p "This is free software. Download the " + (a (@ (href "https://git.cbaines.net/guix/data-service/")) + "source code here") "."))))) + #:extra-headers ,extra-headers)) + +(define (index guix-revisions) + (layout + #:extra-headers + '((cache-control . ((max-age . 60)))) + #:body + `(,(header) + (div + (@ (class "container")) + (h1 "Guix Data Service") + (form (@ (id "compare") + (action "/compare")) + (div + (@ (class "form-group")) + (label (@ (for "base_commit")) + "Base commit") + (input (@ (type "text") + (class "form-control") + (id "base_commit") + (name "base_commit") + (placeholder "base commit")))) + (div + (@ (class "form-group")) + (label (@ (for "target_commit")) + "Target commit") + (input (@ (type "text") + (class "form-control") + (id "target_commit") + (name "target_commit") + (placeholder "target commit")))) + (button + (@ (type "submit") + (class "btn btn-lg btn-primary")) + "Compare")) + (h3 "Recent fetched revisions") + ,(if (null? guix-revisions) + '(p "No revisions") + `(table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-6")) "Source Repository URL") + (th (@ (class "col-md-6")) "Commit"))) + (tbody + ,@(map + (match-lambda + ((id url commit store_path) + `(tr + (td ,url) + (td (samp ,commit))))) + guix-revisions)))))))) + +(define (compare base-commit + target-commit + new-packages + removed-packages + version-changes + other-changes) + (layout + #:extra-headers + '((cache-control . ((max-age . 60)))) + #:body + `(,(header) + (div + (@ (class "container")) + (h1 "Comparing " + (samp ,(string-take base-commit 8) "…") + " and " + (samp ,(string-take target-commit 8) "…")) + (h3 "New packages") + ,(if (null? new-packages) + '(p "No new packages") + `(table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-3")) "Name") + (th (@ (class "col-md-9")) "Version"))) + (tbody + ,@(map + (match-lambda + ((name . version) + `(tr + (td ,name) + (td ,version)))) + new-packages)))) + (h3 "Removed packages") + ,(if (null? removed-packages) + '(p "No removed packages") + `(table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-3")) "Name") + (th (@ (class "col-md-9")) "Version"))) + (tbody + ,@(map + (match-lambda + ((name . version) + `(tr + (td ,name) + (td ,version)))) + removed-packages)))) + (h3 "Version changes") + ,(if (null? version-changes) + '(p "No version changes") + `(table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-3")) "Name") + (th (@ (class "col-md-9")) "Versions"))) + (tbody + ,@(map + (match-lambda + ((name . versions) + `(tr + (td ,name) + (td (ul + ,@(map (match-lambda + ((type . version) + `(li (@ (class ,(if (eq? type 'base) + "text-danger" + "text-success"))) + ,version + ,(if (eq? type 'base) + " (old)" + " (new)")))) + versions)))))) + version-changes)))) + (h3 "Other changed packages") + ,@(if (null? other-changes) + '((p "No other changes")) + `((p "The metadata or derivation for these packages has changed.") + (table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-3")) "Name") + (th (@ (class "col-md-9")) "Version"))) + (tbody + ,@(map + (match-lambda + (((name . version) . (metadata-id derivation-id)) + `(tr + (td ,name) + (td ,version)))) + other-changes))))))))) + +(define (unknown id) + (layout + #:body + `(,(header) + (div (@ (class "container")) + (h1 "Patch not found") + (p "There is no submission with id " (strong ,id)) + (p (a (@ (href "/")) "Try another one?")))))) + +(define (error-page message) + (layout + #:body + `(,(header) + (div (@ (class "container")) + (h1 "Error") + (p "An error occurred. Sorry about that!") + ,message + (p (a (@ (href "/")) "Try something else?")))))) |