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 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 web server)
  #:use-module (guix store)
  #: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
                          call-with-delay-logging))
  #:use-module (guix-qa-frontpage database)
  #:use-module (guix-qa-frontpage derivation-changes)
  #:use-module (guix-qa-frontpage patchwork)
  #:use-module (guix-qa-frontpage mumi)
  #:use-module (guix-qa-frontpage branch)
  #: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 branch)
  #:use-module (guix-qa-frontpage view issue)
  #:export (start-guix-qa-frontpage-web-server))

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

  (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 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!)
       (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
              (with-sqlite-cache
               database
               'master-branch-data
               master-branch-data
               #:ttl 6000)))
         (render-html
          #:sxml
          (master-branch-view substitute-availability))))
      (('GET "branch" branch)
       (let ((revisions
              derivation-changes
              substitute-availability
              up-to-date-with-master
              master-branch-systems-with-low-substitute-availability
              (with-sqlite-cache
               database
               'branch-data
               branch-data
               #:args
               (list branch)
               #:version 2
               #:ttl 6000)))
         (render-html
          #:sxml
          (branch-view branch
                       revisions
                       derivation-changes
                       substitute-availability
                       up-to-date-with-master
                       master-branch-systems-with-low-substitute-availability))))
      (('GET "branch" branch "package-changes")
       (let ((revisions
              derivation-changes
              substitute-availability
              up-to-date-with-master
              master-branch-systems-with-low-substitute-availability
              (with-sqlite-cache
               database
               'branch-data
               branch-data
               #:args
               (list branch)
               #:version 2
               #: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
                #:ttl 1800))
              (latest-series-with-overall-statuses
               (map
                (lambda (series)
                  (append series
                          `((overall-status
                             .
                             ,(with-sqlite-cache
                               database
                               'issue-patches-overall-status
                               (const #f)
                               #:store-computed-value? #f
                               #:args (list (first series))
                               #:ttl 3600)))))
                latest-series))
              (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 (eq? a-overall-status
                                 'important-checks-passing)
                            (< (first a)
                               (first b))
                            (> (first a)
                               (first b)))
                        (cond
                         ((eq? a-overall-status 'important-checks-passing)
                          #t)
                         ((eq? b-overall-status 'important-checks-passing)
                          #f)
                         ((eq? a-overall-status 'unknown)
                          #f)
                         ((eq? b-overall-status 'unknown)
                          #t)
                         (else
                          (< (first a)
                             (first b)))))))))
              (master-branch-substitute-availability
               (with-sqlite-cache
                database
                'master-branch-data
                master-branch-data
                #:ttl 6000))
              (systems-with-low-substitute-availability
               (get-systems-with-low-substitute-availability
                master-branch-substitute-availability
                (lset-difference
                 string=?
                 %systems-to-submit-builds-for
                 %systems-with-expected-low-substitute-availability))))
         (render-html
          #:sxml
          (patches-view (if (> (length sorted-latest-series)
                               patch-issues-to-show)
                            (take sorted-latest-series patch-issues-to-show)
                            sorted-latest-series)
                        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
                    '((important-checks-passing . "green")
                      (important-checks-failing . "red")
                      (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 '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 '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
                                #:ttl 1800)
                               (string->number number))))
         (if series
             (let* ((base-and-target-refs
                     derivation-changes
                     change-details
                     builds-missing?
                     comparison-details
                     (with-sqlite-cache
                      database
                      'issue-data
                      issue-data
                      #:args
                      (list (string->number number))
                      #:version 2
                      #:ttl 6000))
                    (master-branch-substitute-availability
                     (with-sqlite-cache
                      database
                      'master-branch-data
                      master-branch-data
                      #:ttl 6000))
                    (systems-with-low-substitute-availability
                     (get-systems-with-low-substitute-availability
                      master-branch-substitute-availability
                      (lset-difference
                       string=?
                       %systems-to-submit-builds-for
                       %systems-with-expected-low-substitute-availability))))
               (render-html
                #:sxml (issue-view number
                                   series
                                   (assq-ref (assq-ref series 'mumi)
                                             'tags)
                                   (and base-and-target-refs
                                        (revision-comparison-url
                                         base-and-target-refs
                                         #:json? #f))
                                   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)))))
      ((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 metrics-registry
                                             #:key (controller-args '()))
  (define controller
    (apply make-controller assets-directory database metrics-registry
           controller-args))

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