path: root/guix-qa-frontpage/server.scm

;;; 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 (srfi srfi-71)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 match)
  #:use-module (web http)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (prometheus)
  #:use-module (system repl error-handling)
  #:use-module (fibers)
  #:use-module (fibers scheduler)
  #:use-module (fibers conditions)
  #:use-module (guix store)
  #:use-module ((guix build syscalls)
                #:select (set-thread-name))
  #:use-module (guix-data-service web util)
  #:use-module ((guix-data-service web query-parameters)
                #:select (parse-query-string))
  #:use-module ((guix-build-coordinator utils)
                #:select (with-time-logging get-gc-metrics-updater
                          get-port-metrics-updater
                          call-with-delay-logging))
  #:use-module ((guix-build-coordinator utils fibers)
                #:select (run-server/patched call-with-sigint))
  #:use-module (guix-qa-frontpage database)
  #:use-module (guix-qa-frontpage derivation-changes)
  #:use-module (guix-qa-frontpage reproducible-builds)
  #:use-module (guix-qa-frontpage patchwork)
  #:use-module (guix-qa-frontpage mumi)
  #:use-module (guix-qa-frontpage debbugs)
  #:use-module (guix-qa-frontpage branch)
  #:use-module (guix-qa-frontpage package)
  #:use-module (guix-qa-frontpage issue)
  #:use-module (guix-qa-frontpage git-repository)
  #:use-module (guix-qa-frontpage manage-builds)
  #:use-module (guix-qa-frontpage manage-patch-branches)
  #: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 patches)
  #:use-module (guix-qa-frontpage view branches)
  #:use-module (guix-qa-frontpage view package)
  #:use-module (guix-qa-frontpage view branch)
  #:use-module (guix-qa-frontpage view issue)
  #:use-module (guix-qa-frontpage view reproducible-builds)
  #:export (start-guix-qa-frontpage))

(define (branch-for-issue database issue-number)
  (let ((branches
          (with-sqlite-cache
           database
           'list-non-master-branches
           list-non-master-branches
           #:ttl 6000)))
    (find (lambda (branch)
            (and=>
             (assoc-ref (cdr branch) "issue_number")
             (lambda (branch-issue-number)
               (= branch-issue-number
                  issue-number))))
          branches)))

(define* (make-controller assets-directory database metrics-registry
                          #:key patch-issues-to-show
                          doc-dir)

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

  (define gc-metrics-updater!
    (get-gc-metrics-updater metrics-registry))

  (define port-metrics-updater!
    (get-port-metrics-updater metrics-registry))

  (define guile-time-metrics-updater
    (let ((internal-real-time
           (make-gauge-metric metrics-registry "guile_internal_real_time"))
          (internal-run-time
           (make-gauge-metric metrics-registry "guile_internal_run_time")))
      (lambda ()
        (metric-set internal-real-time
                    (get-internal-real-time))
        (metric-set internal-run-time
                    (get-internal-run-time)))))

  (lambda (request
           method-and-path-components
           mime-types
           body)

    (define path
      (uri-path (request-uri request)))

    (match method-and-path-components
      (('GET)
       (let ((branches
              (with-sqlite-cache
               database
               'list-non-master-branches
               list-non-master-branches
               #:ttl 300)))
         (render-html
          #:sxml (home branches))))
      (('GET "assets" rest ...)
       (or (handle-static-assets (string-join rest "/")
                                 (request-headers request))
           (list (build-response #:code 404)
                 (string-append
                  "Resource not found: "
                  (uri->string
                   (request-uri request))))))
      (('GET "metrics")
       (gc-metrics-updater!)
       (port-metrics-updater!)
       (guile-time-metrics-updater)
       (list (build-response
              #:code 200
              #:headers '((content-type . (text/plain))
                          (vary . (accept))))
             (lambda (port)
               (write-metrics metrics-registry port))))
      (('GET "branches")
       (let ((branches
              (with-sqlite-cache
               database
               'branches
               (lambda ()
                 (list-branches
                  (list-branches-url 2)))
               #:ttl 60)))
         (render-html
          #:sxml
          (branches-view branches))))
      (('GET "branch" "master")
       (let ((substitute-availability
              systems-with-low-substitute-availability
              package-reproducibility
              (with-sqlite-cache
               database
               'master-branch-data
               master-branch-data
               #:ttl 6000
               #:version 2)))
         (render-html
          #:sxml
          (master-branch-view substitute-availability
                              package-reproducibility))))
      (('GET "branch" branch)
       (let ((revisions
              derivation-changes
              substitute-availability
              package-reproducibility
              up-to-date-with-master
              (with-sqlite-cache
               database
               'branch-data
               branch-data
               #:args
               (list branch)
               #:version 3
               #:ttl 6000))
             (master-branch-substitute-availability
              master-branch-systems-with-low-substitute-availability
              master-branch-package-reproducibility
              (with-sqlite-cache
               database
               'master-branch-data
               master-branch-data
               #:ttl 6000
               #:version 2)))
         (render-html
          #:sxml
          (branch-view branch
                       revisions
                       derivation-changes
                       substitute-availability
                       package-reproducibility
                       up-to-date-with-master
                       master-branch-systems-with-low-substitute-availability))))
      (('GET "branch" branch "package-changes")
       (let ((revisions
              derivation-changes
              substitute-availability
              package-reproducibility
              up-to-date-with-master
              (with-sqlite-cache
               database
               'branch-data
               branch-data
               #:args
               (list branch)
               #:version 3
               #:ttl 6000)))
         (render-html
          #:sxml
          (branch-package-changes-view branch
                                       revisions
                                       derivation-changes
                                       up-to-date-with-master
                                       (or
                                        (and=>
                                         (uri-query (request-uri request))
                                         parse-query-string)
                                        '())))))
      (('GET "patches")
       (let* ((latest-series
               (with-sqlite-cache
                database
                'latest-patchwork-series-by-issue
                latest-patchwork-series-by-issue
                #:args `(#:count ,patch-issues-to-show)
                #:ttl 1800))
              (query-params
               (or (and=>
                    (uri-query (request-uri request))
                    parse-query-string)
                   '()))
              (filtered-statuses
               (filter-map
                (match-lambda
                  ((key . val)
                   (let ((symbol-key (string->symbol key)))
                     (if (and (member symbol-key %overall-statuses)
                              (string=? val "on"))
                         symbol-key
                         #f))))
                query-params))
              (latest-series-branches
               (map
                (match-lambda
                  ((_ . series)
                   (patchwork-series->branch series)))
                latest-series))
              (branch-options
               (sort (delete-duplicates
                      latest-series-branches)
                     string<?))
              (filtered-branches
               (filter-map
                (match-lambda
                  ((key . val)
                   (if (string=? key "branch")
                       val
                       #f)))
                query-params))
              (latest-series-with-overall-statuses
               (filter-map
                (lambda (series branch)
                  (let ((overall-status
                         (with-sqlite-cache
                          database
                          'issue-patches-overall-status
                          (const 'unknown)
                          #:store-computed-value? #f
                          #:args (list (first series))
                          #:ttl 3600)))
                    (if (and (or (null? filtered-statuses)
                                 (member overall-status
                                         filtered-statuses))
                             (or (null? filtered-branches)
                                 (member branch filtered-branches)))
                        (append series
                                `((branch . ,branch)
                                  (overall-status . ,overall-status)))
                        #f)))
                latest-series
                latest-series-branches))
              (sorted-latest-series
               (sort
                latest-series-with-overall-statuses
                (lambda (a b)           ; a less than b
                  (let* ((a-overall-status (or (assq-ref a 'overall-status)
                                               'unknown))
                         (b-overall-status (or (assq-ref b 'overall-status)
                                               'unknown)))
                    (if (eq? a-overall-status
                             b-overall-status)
                        (if (not (eq? a-overall-status 'unknown))
                            (< (first a)
                               (first b))
                            (> (first a)
                               (first b)))
                        (cond
                         ((eq? a-overall-status 'reviewed-looks-good)
                          #t)
                         ((eq? b-overall-status 'reviewed-looks-good)
                          #f)
                         ((eq? a-overall-status 'important-checks-passing)
                          #t)
                         ((eq? b-overall-status 'important-checks-passing)
                          #f)
                         ((eq? a-overall-status 'waiting-for-build-results)
                          #t)
                         ((eq? b-overall-status 'waiting-for-build-results)
                          #f)
                         ((eq? a-overall-status 'unknown)
                          #f)
                         ((eq? b-overall-status 'unknown)
                          #t)
                         (else
                          (< (first a)
                             (first b)))))))))
              (master-branch-substitute-availability
               systems-with-low-substitute-availability
               master-branch-package-reproducibility
               (with-sqlite-cache
                database
                'master-branch-data
                master-branch-data
                #:ttl 6000
                #:version 2)))
         (render-html
          #:sxml
          (patches-view sorted-latest-series
                        filtered-statuses
                        branch-options
                        filtered-branches
                        systems-with-low-substitute-availability))))
      (('GET "issue" (? (lambda (s) (string-suffix? ".svg" s)) number.svg))
       (let* ((number
               (string->number (car (string-split number.svg #\.))))
              (overall-status
               (with-sqlite-cache
                database
                'issue-patches-overall-status
                (const #f)
                #:store-computed-value? #f
                #:args (list number)
                #:ttl 3600))
              (fill
               (or (assq-ref
                    '((reviewed-looks-good      . "darkgreen")
                      (important-checks-passing . "green")
                      (important-checks-failing . "red")
                      (failed-to-apply-patches  . "darkred")
                      (patches-missing          . "pink")
                      (guix-data-service-failed . "yellow")
                      (needs-looking-at         . "orange")
                      (unknown                  . "grey"))
                    overall-status)
                   "grey")))

         (list (build-response
                #:code 200
                #:headers '((content-type . (image/svg+xml))))
               (lambda (port)
                 (simple-format
                  port
                  "
<svg viewBox=\"0 0 100 100\" xmlns=\"http://www.w3.org/2000/svg\">
  <circle cx=\"50\" cy=\"50\" r=\"50\" style=\"fill: ~A;\" />
</svg>"
                  fill)))))
      (('GET "issue" number "status-badge-medium.svg")
       (let* ((overall-status
               (with-sqlite-cache
                database
                'issue-patches-overall-status
                (const #f)
                #:store-computed-value? #f
                #:args (list (string->number number))
                #:ttl 3600)))

         (list (build-response
                #:code 200
                #:headers '((content-type . (image/svg+xml))))
               (lambda (port)
                 (display
                  (cond
                   ((eq? overall-status 'reviewed-looks-good)
                    "
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
  <clipPath id=\"clip\">
    <rect width=\"140\" height=\"36\" rx=\"4\"/>
  </clipPath>
  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"#666\" />
    <stop offset=\"1\" stop-color=\"#333\" />
  </linearGradient>
  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"green\" />
    <stop offset=\"1\" stop-color=\"darkgreen\" />
  </linearGradient>
  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
    <text x=\"90\" y=\"22\" fill=\"#fff\">Reviewed</text>
  </g>
</svg>")
                   ((eq? overall-status 'important-checks-passing)
                    "
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
  <clipPath id=\"clip\">
    <rect width=\"140\" height=\"36\" rx=\"4\"/>
  </clipPath>
  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"#666\" />
    <stop offset=\"1\" stop-color=\"#333\" />
  </linearGradient>
  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"lawngreen\" />
    <stop offset=\"1\" stop-color=\"green\" />
  </linearGradient>
  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
    <text x=\"90\" y=\"22\" fill=\"#000\">Succeeding</text>
  </g>
</svg>")
                   ((eq? overall-status 'failed-to-apply-patches)
                    "
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
  <clipPath id=\"clip\">
    <rect width=\"140\" height=\"36\" rx=\"4\"/>
  </clipPath>
  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"#666\" />
    <stop offset=\"1\" stop-color=\"#333\" />
  </linearGradient>
  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"red\" />
    <stop offset=\"1\" stop-color=\"red\" />
  </linearGradient>
  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
    <text x=\"90\" y=\"22\" fill=\"#000\">Investigate</text>
  </g>
</svg>")
                   ((eq? overall-status 'large-number-of-builds)
                    "
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
  <clipPath id=\"clip\">
    <rect width=\"140\" height=\"36\" rx=\"4\"/>
  </clipPath>
  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"#666\" />
    <stop offset=\"1\" stop-color=\"#333\" />
  </linearGradient>
  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"purple\" />
    <stop offset=\"1\" stop-color=\"purple\" />
  </linearGradient>
  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
    <text x=\"90\" y=\"22\" fill=\"#fff\">Investigate</text>
  </g>
</svg>")
                   ((eq? overall-status 'waiting-for-build-results)
                    "
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
  <clipPath id=\"clip\">
    <rect width=\"140\" height=\"36\" rx=\"4\"/>
  </clipPath>
  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"#666\" />
    <stop offset=\"1\" stop-color=\"#333\" />
  </linearGradient>
  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"lightblue\" />
    <stop offset=\"1\" stop-color=\"lightblue\" />
  </linearGradient>
  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
    <text x=\"90\" y=\"22\" fill=\"#000\">Pending</text>
  </g>
</svg>")
                   ((eq? overall-status 'guix-data-service-failed)
                    "
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
  <clipPath id=\"clip\">
    <rect width=\"140\" height=\"36\" rx=\"4\"/>
  </clipPath>
  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"#666\" />
    <stop offset=\"1\" stop-color=\"#333\" />
  </linearGradient>
  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"yellow\" />
    <stop offset=\"1\" stop-color=\"yellow\" />
  </linearGradient>
  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
    <text x=\"90\" y=\"22\" fill=\"#000\">Investigate</text>
  </g>
</svg>")
                   ((eq? overall-status 'needs-looking-at)
                    "
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
  <clipPath id=\"clip\">
    <rect width=\"140\" height=\"36\" rx=\"4\"/>
  </clipPath>
  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"#666\" />
    <stop offset=\"1\" stop-color=\"#333\" />
  </linearGradient>
  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"orange\" />
    <stop offset=\"1\" stop-color=\"darkorange\" />
  </linearGradient>
  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
    <text x=\"90\" y=\"22\" fill=\"#000\">Investigate</text>
  </g>
</svg>")
                   ((eq? overall-status 'important-checks-failing)
                    "
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
  <clipPath id=\"clip\">
    <rect width=\"140\" height=\"36\" rx=\"4\"/>
  </clipPath>
  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"#666\" />
    <stop offset=\"1\" stop-color=\"#333\" />
  </linearGradient>
  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"lightcoral\" />
    <stop offset=\"1\" stop-color=\"red\" />
  </linearGradient>
  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
    <text x=\"90\" y=\"22\" fill=\"#000\">Failing</text>
  </g>
</svg>")
                   (else
                    "
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"36\">
  <clipPath id=\"clip\">
    <rect width=\"140\" height=\"36\" rx=\"4\"/>
  </clipPath>
  <linearGradient id=\"job\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"#666\" />
    <stop offset=\"1\" stop-color=\"#333\" />
  </linearGradient>
  <linearGradient id=\"status\" x1=\"0\" x2=\"0\" y1=\"0\" y2=\"1\">
    <stop offset=\"0\" stop-color=\"white\" />
    <stop offset=\"1\" stop-color=\"grey\" />
  </linearGradient>
  <g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"14\" text-anchor=\"middle\">
    <rect width=\"40\" height=\"36\" fill=\"url(#job)\"/>
    <text x=\"20\" y=\"22\" fill=\"#fff\">QA</text>
    <rect x=\"40\" width=\"100\" height=\"36\" fill=\"url(#status)\"/>
    <text x=\"90\" y=\"22\" fill=\"#000\">Unknown</text>
  </g>
</svg>"))
                  port)))))
      (('GET "issue" number)
       (let ((series (assq-ref (with-sqlite-cache
                                database
                                'latest-patchwork-series-by-issue
                                latest-patchwork-series-by-issue
                                #:args `(#:count ,patch-issues-to-show)
                                #:ttl 1800)
                               (string->number number))))
         (if series
             (let* ((base-and-target-refs
                     derivation-changes
                     cross-derivation-changes
                     change-details
                     builds-missing?
                     comparison-details
                     (with-sqlite-cache
                      database
                      'issue-data
                      issue-data
                      #:args
                      (list (string->number number))
                      #:version 3
                      #:ttl 6000))
                    (create-branch-for-issue-log
                     (select-create-branch-for-issue-log
                      database
                      number))
                    (branch
                     (patchwork-series->branch series))
                    (master-branch-substitute-availability
                     systems-with-low-substitute-availability
                     master-branch-package-reproducibility
                     (with-sqlite-cache
                      database
                      'master-branch-data
                      master-branch-data
                      #:ttl 6000
                      #:version 2)))
               (render-html
                #:sxml (issue-view number
                                   series
                                   branch
                                   (assq-ref (assq-ref series 'mumi)
                                             'tags)
                                   base-and-target-refs
                                   create-branch-for-issue-log
                                   (and base-and-target-refs
                                        (revision-comparison-url
                                         base-and-target-refs
                                         #:json? #f))
                                   derivation-changes
                                   cross-derivation-changes
                                   builds-missing?
                                   change-details
                                   comparison-details
                                   systems-with-low-substitute-availability)))
             (or
              (and=> (branch-for-issue database
                                       (string->number number))
                     (match-lambda
                       ((name . details)
                        (list
                         (build-response
                          #:code 301
                          #:headers `((location . ,(string->uri
                                                    (string-append
                                                     "https://qa.guix.gnu.org/branch/" name)))))
                         #f))
                       (_ #f)))
              (render-html
               #:sxml (general-not-found
                       "Issue not found"
                       "This could mean the issue does not exist, it
has no patches or has been closed.")
               #:code 404)))))
      (('GET "issue" number "package-changes")
       (let ((revisions
              derivation-changes
              cross-derivation-changes
              substitute-availability
              up-to-date-with-master
              master-branch-systems-with-low-substitute-availability
              (with-sqlite-cache
               database
               'issue-data
               issue-data
               #:args
               (list (string->number number))
               #:version 3
               #:ttl 6000)))
         (render-html
          #:sxml
          (issue-package-changes-view number
                                      derivation-changes
                                      (or
                                       (and=>
                                        (uri-query (request-uri request))
                                        parse-query-string)
                                       '())))))
      (('GET "issue" number "package-cross-changes")
       (let ((revisions
              derivation-changes
              cross-derivation-changes
              substitute-availability
              up-to-date-with-master
              master-branch-systems-with-low-substitute-availability
              (with-sqlite-cache
               database
               'issue-data
               issue-data
               #:args
               (list (string->number number))
               #:version 3
               #:ttl 6000)))
         (render-html
          #:sxml
          (issue-package-cross-changes-view number
                                            "x86_64-linux"
                                            cross-derivation-changes
                                            (or
                                             (and=>
                                              (uri-query (request-uri request))
                                              parse-query-string)
                                             '())))))
      (('GET "issue" number "prepare-review")
       (let ((revisions
              derivation-changes
              cross-derivation-changes
              substitute-availability
              up-to-date-with-master
              master-branch-systems-with-low-substitute-availability
              (with-sqlite-cache
               database
               'issue-data
               issue-data
               #:args
               (list (string->number number))
               #:version 3
               #:ttl 6000)))
         (render-html
          #:sxml
          (issue-prepare-review-view number
                                     (or
                                      (and=>
                                       (uri-query (request-uri request))
                                       parse-query-string)
                                      '())))))
      (('GET "reproducible-builds")
       (let ((issue-data
              (with-sqlite-cache
               database
               'fetch-issues-with-guix-tag
               fetch-issues-with-guix-tag
               #:ttl 3000
               #:args '("reproducibility")))
             (substitute-availability
              systems-with-low-substitute-availability
              package-reproducibility
              (with-sqlite-cache
               database
               'master-branch-data
               master-branch-data
               #:ttl 6000
               #:version 2)))
         (render-html
          #:sxml
          (reproducible-builds-view package-reproducibility
                                    issue-data))))

      (('GET "package" name)
       (let ((package-data
              (with-sqlite-cache
               database
               'package-data
               package-data
               #:ttl 3000
               #:args (list name))))
         (render-html
          #:sxml (package-view package-data))))

      (('GET "README")
       (let ((filename (string-append doc-dir "/README.html")))
         (if (file-exists? filename)
             (render-html
              #:sxml (readme (call-with-input-file filename
                               get-string-all)))
             (render-html
              #:sxml (general-not-found
                      "README not found"
                      "The README.html file does not exist")
              #:code 404))))
      ((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 port host assets-directory
                                  database metrics-registry
                                  #:key (controller-args '())
                                  submit-builds?
                                  patch-issues-to-show
                                  generate-reproducible.json)
  (define controller
    (apply make-controller assets-directory database metrics-registry
           controller-args))

  (when generate-reproducible.json
    (start-generate-reproducible.json-thread))

  (let ((finished? (make-condition)))
    (call-with-new-thread
     (lambda ()
       (catch 'system-error
         (lambda ()
           (set-thread-name "maintenance"))
         (const #t))

       (run-fibers
        (lambda ()
          (when submit-builds?
            (start-submit-patch-builds-fiber database
                                             "http://127.0.0.1:8746"
                                             "https://data.qa.guix.gnu.org"
                                             metrics-registry
                                             #:series-count
                                             patch-issues-to-show))
          (wait finished?))
        #:parallelism 1)))

    (call-with-sigint
     (lambda ()
       (run-fibers
        (lambda ()
          (let* ((current (current-scheduler))
                 (schedulers
                  (cons current (scheduler-remote-peers current))))
            (for-each
             (lambda (i sched)
               (spawn-fiber
                (lambda ()
                  (catch 'system-error
                    (lambda ()
                      (set-thread-name
                       (string-append "fibers " (number->string i))))
                    (const #t)))
                sched))
             (iota (length schedulers))
             schedulers))

          (run-server/patched
           (lambda (request body)
             (apply values (handler request body controller)))
           #:host host
           #:port port)

          (wait finished?))
        #:parallelism 2))
     finished?)))