Add lots more functionality

8 files changed, 1301 insertions, 1 deletions

diff --git a/guix-qa-frontpage/database.scm b/guix-qa-frontpage/database.scm
new file mode 100644
index 0000000..cca3814
--- /dev/null
+++ b/guix-qa-frontpage/database.scm
@@ -0,0 +1,385 @@
+;;; Guix QA Frontpage
+;;;
+;;; Copyright © 2021, 2022 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-qa-frontpage database)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 exceptions)
+  #:use-module (web uri)
+  #:use-module (sqlite3)
+  #:use-module (fibers)
+  #:use-module (prometheus)
+  #:use-module (guix narinfo)
+  #:use-module (guix derivations)
+  #:use-module (guix-build-coordinator utils)
+  #:use-module (guix-build-coordinator utils fibers)
+  #:export (setup-database
+
+            database-optimize
+            database-spawn-fibers
+
+            database-call-with-transaction
+
+            with-sqlite-cache))
+
+(define-record-type <database>
+  (make-database database-file reader-thread-channel writer-thread-channel
+                 metrics-registry)
+  database?
+  (database-file          database-file)
+  (reader-thread-channel  database-reader-thread-channel)
+  (writer-thread-channel  database-writer-thread-channel)
+  (metrics-registry       database-metrics-registry))
+
+(define* (db-open database
+                  #:key (write? #t))
+  (define flags
+    `(,@(if write?
+            (list SQLITE_OPEN_READWRITE
+                  SQLITE_OPEN_CREATE)
+
+            (list SQLITE_OPEN_READONLY))
+      ,SQLITE_OPEN_NOMUTEX))
+
+  (sqlite-open database (apply logior flags)))
+
+(define (perform-initial-database-setup db)
+  (define schema
+    "
+CREATE TABLE cache (
+    key TEXT NOT NULL,
+    version INTEGER NOT NULL,
+    timestamp INTEGER NOT NULL,
+    data TEXT NOT NULL
+);
+")
+
+  (sqlite-exec db schema))
+
+(define (setup-database database-file metrics-registry)
+  (let ((db (db-open database-file)))
+    (sqlite-exec db "PRAGMA journal_mode=WAL;")
+    (sqlite-exec db "PRAGMA optimize;")
+    (sqlite-exec db "PRAGMA wal_checkpoint(TRUNCATE);")
+
+    (sqlite-close db))
+
+  (let ((reader-thread-channel
+         (make-worker-thread-channel
+          (lambda ()
+            (let ((db
+                   (db-open database-file #:write? #f)))
+              (sqlite-exec db "PRAGMA busy_timeout = 5000;")
+              (list db)))
+          #:destructor
+          (lambda (db)
+            (sqlite-close db))
+          #:lifetime 50000
+
+          ;; Use a minimum of 2 and a maximum of 8 threads
+          #:parallelism
+          (min (max (current-processor-count)
+                    2)
+               64)
+          #:delay-logger (let ((delay-metric
+                                (make-histogram-metric
+                                 metrics-registry
+                                 "database_read_delay_seconds")))
+                           (lambda (seconds-delayed)
+                             (metric-observe delay-metric seconds-delayed)
+                             (when (> seconds-delayed 1)
+                               (format
+                                (current-error-port)
+                                "warning: database read delayed by ~1,2f seconds~%"
+                                seconds-delayed))))))
+
+        (writer-thread-channel
+         (make-worker-thread-channel
+          (lambda ()
+            (let ((db
+                   (db-open database-file)))
+              (sqlite-exec db "PRAGMA busy_timeout = 5000;")
+              (sqlite-exec db "PRAGMA foreign_keys = ON;")
+              (list db)))
+          #:destructor
+          (lambda (db)
+            (db-optimize db
+                         database-file)
+
+            (sqlite-close db))
+          #:lifetime 500
+
+          ;; SQLite doesn't support parallel writes
+          #:parallelism 1
+          #:delay-logger (let ((delay-metric
+                                (make-histogram-metric
+                                 metrics-registry
+                                 "database_write_delay_seconds")))
+                           (lambda (seconds-delayed)
+                             (metric-observe delay-metric seconds-delayed)
+                             (when (> seconds-delayed 1)
+                               (format
+                                (current-error-port)
+                                "warning: database write delayed by ~1,2f seconds~%"
+                                seconds-delayed)))))))
+
+    (make-database database-file
+                   reader-thread-channel
+                   writer-thread-channel
+                   metrics-registry)))
+
+(define (db-optimize db db-filename)
+  (define (wal-size)
+    (let ((db-wal-filename
+           (string-append db-filename "-wal")))
+
+      (stat:size (stat db-wal-filename))))
+
+  (define MiB (* (expt 2 20) 1.))
+  (define wal-size-threshold
+    (* 5 MiB))
+
+  (when (> (wal-size) wal-size-threshold)
+    (sqlite-exec db "PRAGMA wal_checkpoint(TRUNCATE);")
+
+    (sqlite-exec db
+                 "
+PRAGMA analysis_limit=1000;
+PRAGMA optimize;")))
+
+(define (database-optimize database)
+  (retry-on-error
+   (lambda ()
+     (call-with-worker-thread
+      (database-writer-thread-channel database)
+      (lambda (db)
+        (db-optimize
+         db
+         (database-file database)))))
+   #:times 5
+   #:delay 5))
+
+(define (database-spawn-fibers database)
+  (spawn-fiber
+   (lambda ()
+     (while #t
+       (sleep (* 60 5))                 ; 5 minutes
+       (with-exception-handler
+           (lambda (exn)
+             (simple-format (current-error-port)
+                            "exception when performing WAL checkpoint: ~A\n"
+                            exn))
+         (lambda ()
+           (database-optimize database))
+         #:unwind? #t)))
+   #:parallel? #t))
+
+(define (call-with-time-tracking database thing thunk)
+  (define registry (database-metrics-registry database))
+  (define metric-name
+    (string-append "database_" thing "_duration_seconds"))
+
+  (if registry
+      (let* ((metric
+              (or (metrics-registry-fetch-metric registry metric-name)
+                  (make-histogram-metric registry
+                                         metric-name)))
+             (start-time (get-internal-real-time)))
+        (let ((result (thunk)))
+          (metric-observe metric
+                          (/ (- (get-internal-real-time) start-time)
+                             internal-time-units-per-second))
+          result))
+      (thunk)))
+
+(define %current-transaction-proc
+  (make-parameter #f))
+
+(define* (database-call-with-transaction database proc
+                                         #:key
+                                         readonly?)
+  (define (run-proc-within-transaction db)
+    (if (%current-transaction-proc)
+        (proc db)                       ; already in transaction
+        (begin
+          (sqlite-exec db "BEGIN TRANSACTION;")
+          (with-exception-handler
+              (lambda (exn)
+                (simple-format (current-error-port)
+                               "error: sqlite rolling back transaction\n")
+                (sqlite-exec db "ROLLBACK TRANSACTION;")
+                (raise-exception exn))
+            (lambda ()
+              (call-with-values
+                  (lambda ()
+                    (parameterize ((%current-transaction-proc proc))
+                      (proc db)))
+                (lambda vals
+                  (sqlite-exec db "COMMIT TRANSACTION;")
+                  (apply values vals))))))))
+
+  (match (call-with-worker-thread
+          ((if readonly?
+               database-reader-thread-channel
+               database-writer-thread-channel)
+           database)
+          (lambda (db)
+            (let ((start-time (get-internal-real-time)))
+              (call-with-values
+                  (lambda ()
+                    (run-proc-within-transaction db))
+                (lambda vals
+                  (let ((duration-seconds
+                         (/ (- (get-internal-real-time) start-time)
+                            internal-time-units-per-second)))
+                    (when (and (not readonly?)
+                               (> duration-seconds 2))
+                      (display
+                       (format
+                        #f
+                        "warning: ~a:\n  took ~4f seconds in transaction\n"
+                        proc
+                        duration-seconds)
+                       (current-error-port)))
+
+                    (cons duration-seconds vals)))))))
+    ((duration vals ...)
+     (apply values vals))))
+
+(define (last-insert-rowid db)
+  (let ((statement
+         (sqlite-prepare
+          db
+          "SELECT last_insert_rowid();"
+          #:cache? #t)))
+    (let ((id
+           (vector-ref (sqlite-step statement)
+                       0)))
+
+      (sqlite-reset statement)
+
+      id)))
+
+(define (changes db)
+  (let ((statement
+         (sqlite-prepare
+          db
+          "SELECT changes()"
+          #:cache? #t)))
+    (let ((id
+           (vector-ref (sqlite-step statement)
+                       0)))
+
+      (sqlite-reset statement)
+
+      id)))
+
+(define* (with-sqlite-cache
+          database
+          key
+          proc
+          #:key (args '())
+          (version 1)
+          ttl)
+
+  (define string-key
+    (call-with-output-string
+      (lambda (port)
+        (write key port)
+        (display ": " port)
+        (write args port))))
+
+  (unless (number? ttl)
+    (error "must specify a ttl"))
+
+  (let ((cached-values
+         (call-with-worker-thread
+          (database-reader-thread-channel database)
+          (lambda (db)
+            (let ((statement
+                   (sqlite-prepare
+                    db
+                    "
+SELECT data, timestamp FROM cache WHERE key = :key AND version = :version"
+                    #:cache? #t)))
+
+              (sqlite-bind-arguments
+               statement
+               #:key string-key
+               #:version version)
+
+              (let ((result (sqlite-step statement)))
+                (sqlite-reset statement)
+
+                (match result
+                  (#f 'noval)
+                  (#(data timestamp)
+                   (if (<= (+ timestamp ttl)
+                           (time-second (current-time)))
+                       'noval
+                       (call-with-input-string data read))))))))))
+
+    (when (eq? cached-values 'noval)
+      (simple-format (current-error-port)
+                     "cache miss: ~A\n" string-key))
+
+    (if (eq? cached-values 'noval)
+        (call-with-values
+            (lambda () (apply proc args))
+          (lambda vals
+            (database-call-with-transaction
+             database
+             (lambda (db)
+               (let ((cleanup-statement
+                      (sqlite-prepare
+                       db
+                       "
+DELETE FROM cache WHERE key = :key"
+                       #:cache? #t))
+                     (insert-statement
+                      (sqlite-prepare
+                       db
+                       "
+INSERT INTO cache (key, version, timestamp, data)
+VALUES (:key, :version, :timestamp, :data)"
+                       #:cache? #t)))
+
+                 (sqlite-bind-arguments
+                  cleanup-statement
+                  #:key string-key)
+                 (sqlite-step cleanup-statement)
+                 (sqlite-reset cleanup-statement)
+
+                 (sqlite-bind-arguments
+                  insert-statement
+                  #:key string-key
+                  #:version version
+                  #:timestamp (time-second (current-time))
+                  #:data (call-with-output-string
+                           (lambda (port)
+                             (write vals port))))
+
+                 (sqlite-step insert-statement)
+                 (sqlite-reset insert-statement))))
+
+            (apply values vals)))
+        (apply values cached-values))))
diff --git a/guix-qa-frontpage/guix-data-service.scm b/guix-qa-frontpage/guix-data-service.scm
new file mode 100644
index 0000000..a9c41f4
--- /dev/null
+++ b/guix-qa-frontpage/guix-data-service.scm
@@ -0,0 +1,52 @@
+(define-module (guix-qa-frontpage guix-data-service)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:use-module (json)
+  #:use-module (guix-build-coordinator utils)
+  #:use-module (guix-qa-frontpage patchwork)
+  #:export (patch-series-derivation-changes-url
+            patch-series-derivation-changes))
+
+(define (patch-series-derivation-changes-url series)
+  (define comparison-check
+    (find (lambda (check)
+            (string=? (assoc-ref check "context")
+                      "comparison"))
+          (patchwork-patch-checks
+           (assoc-ref (first (assoc-ref series "patches"))
+                      "checks"))))
+
+  (and comparison-check
+       (let ((url-query-params
+              (uri-query
+               (string->uri
+                (assoc-ref comparison-check "target_url")))))
+
+         (string-append
+          "https://data.qa.guix.gnu.org/compare/package-derivations.json?"
+          url-query-params
+          "&field=builds&limit_results=&all_results=on"))))
+
+(define (patch-series-derivation-changes url)
+  (retry-on-error
+   (lambda ()
+     (let-values (((response body)
+                   (http-get (string->uri url))))
+       (if (eq? (peek "CODE" (response-code response))
+                404)
+           (values #f #f)
+           (let ((json-body
+                  (json-string->scm (utf8->string body))))
+             (if (assoc-ref json-body "error")
+                 (values #f #f)
+                 (values (vector->list
+                          (assoc-ref json-body
+                                     "derivation_changes"))
+                         (alist-delete "derivation_changes"
+                                       json-body)))))))
+   #:times 6
+   #:delay 30))
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
new file mode 100644
index 0000000..b6541d9
--- /dev/null
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -0,0 +1,180 @@
+(define-module (guix-qa-frontpage manage-builds)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-71)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
+  #:use-module (guix-build-coordinator utils)
+  #:use-module (guix-build-coordinator client-communication)
+  #:use-module (guix-qa-frontpage database)
+  #:use-module (guix-qa-frontpage patchwork)
+  #:use-module (guix-qa-frontpage guix-data-service)
+  #:export (start-submit-patch-builds-thread))
+
+(define (start-submit-patch-builds-thread database
+                                          build-coordinator
+                                          guix-data-service)
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (simple-format #t "submitting patch builds\n")
+       (let ((series (with-sqlite-cache
+                      database
+                      'latest-patchwork-series-by-issue
+                      latest-patchwork-series-by-issue
+                      #:ttl 3000)))
+
+         (for-each
+          (match-lambda
+            ((issue-number . series)
+             (simple-format #t
+                            "considering submitting builds for issue ~A\n"
+                            issue-number)
+
+             (let ((derivation-changes
+                    change-details
+                    (with-sqlite-cache
+                     database
+                     'derivation-changes
+                     patch-series-derivation-changes
+                     #:args
+                     (list (patch-series-derivation-changes-url series))
+                     #:ttl 6000)))
+
+               (when derivation-changes
+                 (let ((target-commit
+                        (assoc-ref
+                         (assoc-ref
+                          (assoc-ref change-details
+                                     "revisions")
+                          "target")
+                         "commit")))
+
+                   (submit-builds-for-issue build-coordinator
+                                            guix-data-service
+                                            issue-number
+                                            derivation-changes
+                                            target-commit))))))
+          (take series 10)))))))
+
+(define* (submit-build build-coordinator guix-data-service derivation
+                       #:key (priority 0) (tags '()))
+  (retry-on-error
+   (lambda ()
+     (let ((response
+            (send-submit-build-request
+             build-coordinator
+             derivation
+             (list guix-data-service)
+             #f
+             priority
+             #t
+             #t
+             #t
+             tags)))
+       (let ((no-build-submitted-response
+              (assoc-ref response "no-build-submitted")))
+         (if no-build-submitted-response
+             (simple-format #t "skipped: ~A\n"
+                            no-build-submitted-response)
+             (simple-format #t "build submitted as ~A\n"
+                            (assoc-ref response "build-submitted"))))))
+   ;; The TTL Guix uses for transient failures fetching substitutes is 10
+   ;; minutes, so we need to retry for longer than that
+   #:times 30
+   #:delay 30))
+
+(define (cancel-issue-builds-not-for-revision build-coordinator
+                                              issue
+                                              revision
+                                              derivations)
+  (define (builds-after id)
+    (vector->list
+     (assoc-ref
+      (request-builds-list build-coordinator
+                           #:tags
+                           `(((key . category)
+                              (value . package))
+                             ((key . issue)
+                              (value . ,issue)))
+                           #:not-tags
+                           `(((key . revision)
+                              (value . ,revision)))
+                           #:canceled #f
+                           #:processed #f
+                           #:limit 1000
+                           #:after-id id)
+      "builds")))
+
+  (simple-format (current-error-port)
+                 "canceling builds for issue ~A and not revision ~A\n"
+                 issue
+                 revision)
+  (let loop ((builds (builds-after #f)))
+    (for-each
+     (lambda (build-details)
+       (unless (member derivations
+                       (assoc-ref build-details "derivation-name"))
+         (retry-on-error
+          (lambda ()
+            (send-cancel-build-request build-coordinator
+                                       (assoc-ref build-details "uuid")))
+          #:times 6
+          #:delay 15)
+         (simple-format (current-error-port)
+                        "canceled ~A\n"
+                        (assoc-ref build-details "uuid"))))
+     builds)
+    (unless (null? builds)
+      (loop (builds-after
+             (assoc-ref (last builds) "uuid"))))))
+
+(define* (submit-builds-for-issue build-coordinator
+                                  guix-data-service
+                                  issue
+                                  derivation-changes
+                                  target-commit)
+  (define systems
+    '("x86_64-linux"
+      "i686-linux"
+      "aarch64-linux"
+      "armhf-linux"))
+
+  (define target-derivations
+    (fold (lambda (package result)
+            (fold
+             (lambda (change result)
+               (if (and (string=? (assoc-ref change "target")
+                                  "")
+                        (member (assoc-ref change "system")
+                                systems)
+                        (eq? (vector-length
+                              (assoc-ref change "builds"))
+                             0))
+                   (cons (assoc-ref change "derivation-file-name")
+                         result)
+                   result))
+             result
+             (vector->list
+              (assoc-ref package "target"))))
+          '()
+          derivation-changes))
+
+  (for-each (lambda (derivation)
+              (submit-build build-coordinator
+                            guix-data-service
+                            derivation
+                            #:priority 0
+                            #:tags
+                            `(((key . category)
+                               (value . package))
+                              ((key . issue)
+                               (value . ,issue))
+                              ((key . revision)
+                               (value . ,target-commit)))))
+            target-derivations)
+
+  (cancel-issue-builds-not-for-revision
+   build-coordinator
+   issue
+   target-commit
+   target-derivations))
diff --git a/guix-qa-frontpage/patchwork.scm b/guix-qa-frontpage/patchwork.scm
index 7d2da7d..69949e2 100644
--- a/guix-qa-frontpage/patchwork.scm
+++ b/guix-qa-frontpage/patchwork.scm
@@ -11,7 +11,10 @@
   #:use-module (guix-build-coordinator utils)
   #:export (%patchwork-instance
 
-            patchwork-patches))
+            patchwork-patches
+            latest-patchwork-series-by-issue
+
+            patchwork-patch-checks))
 
 (define %patchwork-instance
   (make-parameter "https://patches.guix-patches.cbaines.net"))
@@ -103,3 +106,74 @@
   (retry-on-error (lambda () (make-request initial-uri))
                   #:times 10
                   #:delay 5))
+
+(define* (latest-patchwork-series-by-issue
+          #:key patchwork)
+  (define (patch->issue-number patch)
+    (string->number
+     (match:substring
+      (string-match "\\[bug#([0-9]*).*\\]"
+                    (assoc-ref patch "name"))
+      1)))
+
+  (let ((result
+         (make-hash-table 2048)))
+
+    (for-each
+     (lambda (patch)
+       (let ((issue-number
+              (patch->issue-number patch))
+             (patch-series
+              (assoc-ref patch "series")))
+
+         ;; Some patches are missing series when patchwork has trouble
+         ;; processing them
+         (when (not (eq? (vector-length patch-series) 0))
+           (or (and=>
+                (hash-ref result issue-number)
+                (lambda (series)
+                  (let ((patch-series-number
+                         (assoc-ref (vector-ref patch-series 0)
+                                    "id")))
+                    (when (eq? (assoc-ref series "id")
+                               patch-series-number)
+                      (hash-set!
+                       result
+                       issue-number
+                       `(,@(alist-delete "patches" series)
+                         ("patches" . (,@(assoc-ref series "patches")
+                                       ,patch))))))))
+               (hash-set!
+                result
+                issue-number
+                `(,@(vector-ref patch-series 0)
+                  ("patches" . (,patch))))))))
+     (patchwork-patches #:patchwork patchwork))
+
+    (sort!
+     (hash-map->list cons result)
+     (lambda (a b)
+       (> (first a)
+          (first b))))))
+
+(define (patchwork-patch-checks checks-url)
+  ;; Patchwork uses http URIs, so convert here to avoid the redirect
+  (define https-uri
+    (string->uri
+     (string-append
+      "https:"
+      (string-join
+       (drop (string-split checks-url #\:) 1)
+       ":"))))
+
+  (define (make-request)
+    (let-values (((response body)
+                  (http-request https-uri
+                                #:decode-body? #f)))
+      (vector->list
+       (json-string->scm (utf8->string body)))))
+
+  (retry-on-error make-request
+                  #:times 10
+                  #:delay 5))
+
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm
new file mode 100644
index 0000000..1747098
--- /dev/null
+++ b/guix-qa-frontpage/server.scm
@@ -0,0 +1,130 @@
+;;; Guix QA Frontpage
+;;;
+;;; Copyright © 2022 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-qa-frontpage server)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 match)
+  #:use-module (web http)
+  #:use-module (web request)
+  #:use-module (web uri)
+  #:use-module (system repl error-handling)
+  #:use-module (fibers web server)
+  #:use-module (guix store)
+  #:use-module (guix-data-service web util)
+  #:use-module (guix-qa-frontpage database)
+  #:use-module (guix-qa-frontpage patchwork)
+  #:use-module (guix-qa-frontpage guix-data-service)
+  #:use-module (guix-qa-frontpage view util)
+  #:use-module (guix-qa-frontpage view home)
+  #:use-module (guix-qa-frontpage view issue)
+  #:export (start-guix-qa-frontpage-web-server))
+
+(define (make-controller assets-directory database)
+
+  (define handle-static-assets
+    (if (string-prefix? (%store-prefix)
+                        assets-directory)
+        (static-asset-from-store-renderer assets-directory)
+        (static-asset-from-directory-renderer assets-directory)))
+
+  (lambda (request
+           method-and-path-components
+           mime-types
+           body)
+
+    (define path
+      (uri-path (request-uri request)))
+
+    (match method-and-path-components
+      (('GET)
+       (render-html
+        #:sxml (home)))
+      (('GET "assets" rest ...)
+       (or (handle-static-assets (string-join rest "/")
+                                 (request-headers request))
+           (not-found (request-uri request))))
+      (('GET "issue" number)
+       (let* ((series (assq-ref (with-sqlite-cache
+                                 database
+                                 'latest-patchwork-series-by-issue
+                                 latest-patchwork-series-by-issue
+                                 #:ttl 600)
+                                (string->number number)))
+              (derivation-changes
+               (with-sqlite-cache
+                database
+                'derivation-changes
+                patch-series-derivation-changes
+                #:args
+                (list (patch-series-derivation-changes-url series))
+                #:ttl 6000)))
+         (render-html
+          #:sxml (issue-view series
+                             derivation-changes))))
+      ((method path ...)
+       (render-html
+        #:sxml (general-not-found
+                "Page not found"
+                "")
+        #:code 404)))))
+
+(define (handler request body controller)
+  (display
+   (format #f "~a ~a\n"
+           (request-method request)
+           (uri-path (request-uri request))))
+
+  (call-with-error-handling
+   (lambda ()
+     (let-values (((request-components mime-types)
+                   (request->path-components-and-mime-type request)))
+       (controller request
+                   (cons (request-method request)
+                         request-components)
+                   mime-types
+                   body)))
+   #:on-error 'backtrace
+   #:post-error (lambda args
+                  (render-html #:sxml (error-page args)
+                               #:code 500))))
+
+(define* (start-guix-qa-frontpage-web-server port host assets-directory
+                                             database)
+  (define controller
+    (make-controller assets-directory database))
+
+  (call-with-error-handling
+   (lambda ()
+     (run-server (lambda (request body)
+                   (apply values (handler request body controller)))
+                 #:host host
+                 #:port port))
+   #:on-error 'backtrace
+   #:post-error (lambda (key . args)
+                  (when (eq? key 'system-error)
+                    (match args
+                      (("bind" "~A" ("Address already in use") _)
+                       (simple-format
+                        (current-error-port)
+                        "\n
+error: guix-data-service could not start, as it could not bind to port ~A
+
+Check if it's already running, or whether another process is using that
+port. Also, the port used can be changed by passing the --port option.\n"
+                        port)))))))
diff --git a/guix-qa-frontpage/view/home.scm b/guix-qa-frontpage/view/home.scm
new file mode 100644
index 0000000..4bc3f5f
--- /dev/null
+++ b/guix-qa-frontpage/view/home.scm
@@ -0,0 +1,27 @@
+(define-module (guix-qa-frontpage view home)
+  #:use-module (guix-qa-frontpage view util)
+  #:export (home))
+
+(define (home)
+  (layout
+   #:description "Guix Quality Assurance"
+   #:body
+   `((main
+      (div (@ (class "row"))
+           (section
+            (h2 "branch: master")))
+      (h2 "Branches")
+      (div
+       (@ (class "row two-element-row"))
+       (section
+        (h3 "branch: staging"))
+       (section
+        (h3 "branch: staging")))
+      (h2 "Patches")
+      (div
+       (@ (class "row two-element-row"))
+       (section
+        (h3 "Checks passing"))
+       (section
+        (h3 "Unreviewed")))))))
+
diff --git a/guix-qa-frontpage/view/issue.scm b/guix-qa-frontpage/view/issue.scm
new file mode 100644
index 0000000..e3e380f
--- /dev/null
+++ b/guix-qa-frontpage/view/issue.scm
@@ -0,0 +1,42 @@
+(define-module (guix-qa-frontpage view issue)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (guix-qa-frontpage view util)
+  #:export (issue-view))
+
+(define (issue-view series derivation-changes)
+  (define builds-by-system-excluding-cross-builds
+    (fold (lambda (package result)
+            (fold
+             (lambda (change result)
+               (if (string=? (assoc-ref change "target")
+                             "")
+                   (let ((system (assoc-ref change "system")))
+                     `((,system . ,(+ 1
+                                      (or (assoc-ref result system)
+                                          0)))
+                       ,@(alist-delete system result)))
+                   result))
+             result
+             (vector->list
+              (assoc-ref package "target"))))
+          '()
+          derivation-changes))
+
+  (layout
+   #:description "Guix Quality Assurance"
+   #:body
+   `((main
+
+      (table
+       (tbody
+        ,@(map
+           (match-lambda
+             ((system . build-count)
+              `(tr
+                (td ,system)
+                (td ,build-count))))
+           builds-by-system-excluding-cross-builds)))
+
+      ,(assoc-ref series "web_url")))))
+
diff --git a/guix-qa-frontpage/view/util.scm b/guix-qa-frontpage/view/util.scm
new file mode 100644
index 0000000..784e499
--- /dev/null
+++ b/guix-qa-frontpage/view/util.scm
@@ -0,0 +1,410 @@
+;;; Guix QA Frontpage
+;;;
+;;; Copyright © 2022 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-qa-frontpage view util)
+  #:use-module (guix-data-service config)
+  #:use-module (guix-data-service web query-parameters)
+  #:use-module (guix-data-service web util)
+  #:use-module (guix-data-service web html-utils)
+  #:use-module ((guix-data-service web render) #:prefix guix-data-service:)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (web uri)
+  #:use-module (texinfo)
+  #:use-module (texinfo html)
+  #:use-module (json)
+  #:export (layout
+            header
+            form-horizontal-control
+
+            display-possible-store-item
+            display-store-item
+            display-store-item-short
+
+            table/branches-with-most-recent-commits
+
+            render-html
+
+            general-not-found
+            error-page
+
+            static-asset-from-store-renderer
+            static-asset-from-directory-renderer))
+
+(define* (layout #:key
+                 (head '())
+                 (body '())
+                 title
+                 description)
+  `((doctype "html")
+    (html
+     (@ (lang "en"))
+     (head
+      (title ,(if title
+                  (string-append title " — Guix Quality Assurance")
+                  "Guix Quality Assurance"))
+      (meta (@ (http-equiv "Content-Type")
+               (content "text/html; charset=UTF-8")))
+      (meta (@ (name "viewport")
+               (content "width=device-width, initial-scale=1")))
+      ,@(if description
+            `((meta
+               (@ (name "description")
+                  (content ,description))))
+            '())
+      (link
+       (@ (rel "stylesheet")
+          (media "screen")
+          (type "text/css")
+          (href "/assets/css/mvp.css")))
+      (style
+          "
+:root {
+  --justify-important: left;
+}
+
+header, main {
+    padding: 1rem;
+}
+
+header {
+    border-bottom: 2px dashed orange;
+}
+
+.row {
+    display: flex;
+
+    border-bottom: 2px dashed orange;
+}
+
+.two-element-row section {
+    width: 50%;
+}
+
+.row section {
+    flex-grow: 1;
+
+    padding-left: 10px;
+
+    margin-top: 10px;
+    margin-bottom: 10px;
+}
+
+.row section:not(:last-child) {
+    border-right: 2px dashed orange;
+}
+
+")
+      ,@head)
+     (body (header
+            (h1 "Guix QA"))
+           ,@body
+           (footer
+            (p "Copyright © 2016—2020 by the GNU Guix community."
+               (br)
+               "Now with even more " (span (@ (class "lambda")) "λ") "! ")
+            (p "This is free software.  Download the "
+               (a (@ (href "https://git.savannah.gnu.org/cgit/guix/data-service.git/"))
+                  "source code here") "."))))))
+
+(define* (form-horizontal-control label query-parameters
+                                  #:key
+                                  name
+                                  help-text
+                                  required?
+                                  options
+                                  (allow-selecting-multiple-options #t)
+                                  font-family
+                                  (type "text")
+                                  (null-string-value "none"))
+  (define (value->text value)
+    (match value
+      (#f "")
+      ((? date? date)
+       (date->string date "~1 ~3"))
+      (other other)))
+
+  (let* ((input-id    (hyphenate-words
+                       (string-downcase label)))
+         (help-span-id (string-append
+                        input-id "-help-text"))
+         (input-name (or name
+                         (underscore-join-words
+                          (string-downcase label))))
+         (has-error? (let ((val
+                            (assq-ref query-parameters
+                                      (string->symbol input-name))))
+                       (if (list? val)
+                           (any invalid-query-parameter? val)
+                           (invalid-query-parameter? val))))
+         (show-help-span?
+          (or help-text has-error? required?)))
+    (if (string=? type "hidden")
+        `(input (@ (class "form-control")
+                   (id ,input-id)
+                   (type ,type)
+                   (name ,input-name)
+                   ,@(match (assq (string->symbol input-name)
+                                  query-parameters)
+                       (#f '())
+                       ((_key . value)
+                        `((value ,(value->text value)))))))
+        `(div
+          (@ (class ,(string-append
+                      "form-group form-group-lg"
+                      (if has-error? " has-error" ""))))
+          (label (@ (for ,input-id)
+                    (class "col-sm-2 control-label"))
+                 ,label)
+          (div
+           (@ (class "col-sm-9"))
+           ,(if options
+                `(select (@ (class "form-control")
+                            (style ,(if font-family
+                                        (string-append
+                                         "font-family: " font-family ";")
+                                        ""))
+                            ,@(if allow-selecting-multiple-options
+                                  '((multiple #t))
+                                  '())
+                            (id ,input-id)
+                            ,@(if show-help-span?
+                                  `((aria-describedby ,help-span-id))
+                                  '())
+
+                            (name ,input-name))
+                   ,@(let ((selected-options
+                            (match (assq (string->symbol input-name)
+                                         query-parameters)
+                              ((_key . value)
+                               (if (not allow-selecting-multiple-options)
+                                   (list value)
+                                   value))
+                              (_ '()))))
+
+                       (map (match-lambda
+                              ((option-label . option-value)
+                               `(option
+                                 (@ ,@(if (member (if (and
+                                                       (string? option-value)
+                                                       (string=? option-value
+                                                                 null-string-value))
+                                                      ""
+                                                      option-value)
+                                                  selected-options)
+                                          '((selected ""))
+                                          '())
+                                    (value ,option-value))
+                                 ,(value->text option-label)))
+                              (option-value
+                               `(option
+                                 (@ ,@(if (member (if (and
+                                                       (string? option-value)
+                                                       (string=? option-value
+                                                                 null-string-value))
+                                                      ""
+                                                      option-value)
+                                                  selected-options)
+                                          '((selected ""))
+                                          '()))
+                                 ,(value->text option-value))))
+                            options)))
+                `(input (@ (class "form-control")
+                           (style ,(if font-family
+                                       (string-append
+                                        "font-family: " font-family ";")
+                                       ""))
+                           (id ,input-id)
+                           (type ,type)
+                           ,@(if required?
+                                 '((required #t))
+                                 '())
+                           ,@(if show-help-span?
+                                 `((aria-describedby ,help-span-id))
+                                 '())
+                           (name ,input-name)
+                           ,@(match (assq (string->symbol input-name)
+                                          query-parameters)
+                               (#f '())
+                               ((_key . ($ <invalid-query-parameter> value))
+                                (if (string=? type "checkbox")
+                                    (if value
+                                        '((checked #t))
+                                        '())
+                                    `((value ,(value->text value)))))
+                               ((_key . value)
+                                (if (string=? type "checkbox")
+                                    (if value
+                                        '((checked #t))
+                                        '())
+                                    `((value ,(value->text value)))))))))
+           ,@(if show-help-span?
+                 `((span (@ (id ,help-span-id)
+                            (class "help-block"))
+                         ,@(if has-error?
+                               (let* ((val
+                                       (assq-ref query-parameters
+                                                 (string->symbol input-name)))
+                                      (messages
+                                       (map invalid-query-parameter-message
+                                            (if (list? val)
+                                                val
+                                                (list val)))))
+                                 `((p
+                                    ,@(if (null? messages)
+                                          '(string "Error: invalid value")
+                                          (map
+                                           (lambda (message)
+                                             `(strong
+                                               (@ (style "display: block;"))
+                                               "Error: "
+                                               ,@(if (list? message)
+                                                     message
+                                                     (list message))))
+                                           (remove (lambda (v)
+                                                     (eq? #f v))
+                                                   messages))))))
+                               '())
+                         ,@(if required? '((strong "Required. ")) '())
+                         ,@(if help-text
+                               (list help-text)
+                               '())))
+                 '()))))))
+
+(define render-html
+  guix-data-service:render-html)
+
+(define (general-not-found header-text body)
+  (layout
+   #:body
+   `((div
+      (@ (class "container"))
+      (h1 ,header-text)
+      (p ,body)))))
+
+(define* (error-page #:optional error)
+  (layout
+   #:body
+   `((div (@ (class "container"))
+          (h1 "An error occurred")
+          (p "Sorry about that!")
+          ,@(if error
+                (match error
+                  ((key . args)
+                   `((b ,key)
+                     (pre ,args))))
+                '())))))
+
+(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 (static-asset-from-store-renderer assets-directory)
+  (define last-modified
+    ;; Use the process start time as the last modified time, as the file
+    ;; metadata in the store is normalised.
+    (current-time))
+
+  (define files
+    (file-system-fold
+     (const #t)                         ; enter
+     (lambda (filename stat result)
+       (let ((relative-filename (string-drop filename
+                                             (+ 1 ; to account for the /
+                                                (string-length
+                                                 assets-directory)))))
+         (cons (cons relative-filename
+                     (call-with-input-file filename
+                       get-bytevector-all))
+               result)))
+     (lambda (name stat result) result) ; down
+     (lambda (name stat result) result) ; up
+     (lambda (name stat result) result) ; skip
+     (lambda (name stat errno result)
+       (error name))
+     '()
+     assets-directory))
+
+  (define (send-file path contents)
+    (list `((content-type
+             . ,(assoc-ref file-mime-types
+                           (file-extension path)))
+            (last-modified . ,(time-utc->date last-modified))
+            (cache-control . (public
+                              ;; Set the max-age at 5 minutes, as the files
+                              ;; could change when the code changes
+                              (max-age . ,(* 60 5)))))
+          contents))
+
+  (lambda (path headers)
+    (and=> (assoc-ref files path)
+           (lambda (contents)
+             (cond ((assoc-ref headers 'if-modified-since)
+                    =>
+                    (lambda (client-date)
+                      (if (time>? last-modified
+                                  (date->time-utc client-date))
+                          (send-file path contents)
+                          (list (build-response #:code 304) ; "Not Modified"
+                                #f))))
+                   (else
+                    (send-file path contents)))))))
+
+(define (static-asset-from-directory-renderer assets-directory)
+  (lambda (path headers)
+    (render-static-file assets-directory path headers)))
+
+(define %not-slash
+  (char-set-complement (char-set #\/)))
+
+(define (render-static-file root path headers)
+  (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 headers '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)))
+              #f))
+        #f)))