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-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 patchwork)
  #:use-module (guix-qa-frontpage mumi)
  #: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

            start-refresh-patch-branches-data-thread
            start-refresh-non-patch-branches-data-thread))

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

  (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))
           (list (build-response #:code 404)
                 (string-append
                  "Resource not found: "
                  (uri->string
                   (request-uri request))))))
      (('GET "metrics")
       (gc-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" branch)
       (let ((derivation-changes
              change-details
              (with-sqlite-cache
               database
               'branch-derivation-changes
               branch-derivation-changes
               #:args
               (list (branch-derivation-changes-url
                      branch
                      #:systems %systems-to-submit-builds-for))
               #:ttl 6000)))
         (render-html
          #:sxml
          (branch-view branch
                       derivation-changes))))
      (('GET "patches")
       (let* ((latest-series
               (with-sqlite-cache
                database
                'latest-patchwork-series-by-issue
                latest-patchwork-series-by-issue
                #:ttl 1200))
              (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))))))))))
         (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)))))
      (('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 1200)
                               (string->number number))))
         (if series
             (let* ((base-and-target-refs
                     (with-sqlite-cache
                      database
                      'issue-branch-base-and-target-refs
                      get-issue-branch-base-and-target-refs
                      #:args (list (string->number number))
                      #:ttl 1200
                      #:store-computed-value? list?))
                    (derivation-changes
                     change-details
                     (call-with-values
                         (lambda ()
                           (and
                            base-and-target-refs
                            (with-exception-handler
                                (lambda (exn)
                                  (simple-format
                                   (current-error-port)
                                   "exception fetching derivation changes: ~A\n"
                                   exn)

                                  (values #f #f))
                              (lambda ()
                                (with-sqlite-cache
                                 database
                                 'derivation-changes
                                 patch-series-derivation-changes
                                 #:args
                                 (list
                                  (patch-series-derivation-changes-url
                                   base-and-target-refs
                                   #:systems %systems-to-submit-builds-for))
                                 #:ttl 6000))
                              #:unwind? #t)))
                       (lambda res
                         (match res
                           ((#f)
                            (values #f #f))
                           (_ (apply values res))))))
                    (comparison-details
                     (and
                      base-and-target-refs
                      (with-exception-handler
                          (lambda (exn)
                            (if (guix-data-service-error? exn)
                                exn
                                (raise-exception exn)))
                        (lambda ()
                          (with-sqlite-cache
                           database
                           'lint-warnings
                           patch-series-comparison
                           #:args
                           (list (patch-series-compare-url
                                  base-and-target-refs))
                           #:ttl 6000))
                        #:unwind? #t))))
               (render-html
                #:sxml (issue-view number
                                   series
                                   (assq-ref (assq-ref series 'mumi)
                                             'tags)
                                   (and base-and-target-refs
                                        (patch-series-compare-url
                                         base-and-target-refs
                                         #:json? #f))
                                   derivation-changes
                                   change-details
                                   comparison-details)))
             (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)))))))

(define* (start-refresh-patch-branches-data-thread
          database
          #:key
          (number-of-series-to-refresh 250))
  (define frequency
    (* 10 60))

  (define (refresh-data)
    (simple-format (current-error-port)
                   "refreshing data...\n")
    (let* ((latest-series
            (with-sqlite-cache
             database
             'latest-patchwork-series-by-issue
             latest-patchwork-series-by-issue
             #:ttl (/ frequency 2)))
           (series-to-refresh
            (if (> (length latest-series)
                   number-of-series-to-refresh)
                (take latest-series number-of-series-to-refresh)
                latest-series)))

      (update-repository!)

      (n-par-for-each
       4
       (lambda (series)
         (let ((derivation-changes
                (with-exception-handler
                    (lambda (exn)
                      (unless
                          (and (guix-data-service-error? exn)
                               ;; This probably just means the target
                               ;; revision hasn't been processed yet. The
                               ;; Guix Data Service should send a more
                               ;; informative response though.
                               (and=> (assoc-ref
                                       (guix-data-service-error-response-body exn)
                                       "error")
                                      (lambda (error)
                                        (string=? error
                                                  "invalid query"))))
                        (simple-format
                         (current-error-port)
                         "failed fetching derivation changes for issue ~A: ~A\n"
                         (car series)
                         exn))

                      #f)
                  (lambda ()
                    (and=>
                     (with-sqlite-cache
                      database
                      'issue-branch-base-and-target-refs
                      get-issue-branch-base-and-target-refs
                      #:args (list (car series))
                      #:ttl 0
                      #:store-computed-value? list?)
                     (lambda (base-and-target-refs)
                       (with-sqlite-cache
                        database
                        'derivation-changes
                        patch-series-derivation-changes
                        #:args
                        (list (patch-series-derivation-changes-url
                               base-and-target-refs
                               #:systems %systems-to-submit-builds-for))
                        #:ttl (/ frequency 2)))))
                  #:unwind? #t)))

           (and derivation-changes
                (with-sqlite-cache
                 database
                 'issue-patches-overall-status
                 (lambda (id)
                   (issue-patches-overall-status
                    derivation-changes
                    (assq-ref (assq-ref series 'mumi)
                              'tags)))
                 #:args (list (car series))
                 #:ttl 0))))
       series-to-refresh)))

  (call-with-new-thread
   (lambda ()
     (while #t
       (let ((start-time (current-time)))
         (with-exception-handler
             (lambda (exn)
               (simple-format
                (current-error-port)
                "exception in data refresh thread: ~A\n"
                exn))
           (lambda ()
             (with-time-logging "refreshing data"
               (with-throw-handler #t
                 refresh-data
                 (lambda args
                   (display (backtrace) (current-error-port))
                   (newline (current-error-port))))))
           #:unwind? #t)

         (let ((time-taken
                (- (current-time) start-time)))
           (if (>= time-taken frequency)
               (simple-format (current-error-port)
                              "warning: refreshing data is behind\n")
               (sleep
                (- frequency time-taken)))))))))

(define (start-refresh-non-patch-branches-data-thread database)
  (define frequency
    (* 30 60))

  (define (refresh-data)
    (simple-format (current-error-port)
                   "refreshing non-patch branches data...\n")
    (update-repository!)

    (let ((branches
           (with-sqlite-cache
            database
            'branches
            (lambda ()
              (remove
               (lambda (branch)
                 (or (string=? (assoc-ref branch "name")
                               "master")
                     (string-prefix? "version-"
                                     (assoc-ref branch "name"))))
               (list-branches
                (list-branches-url 2))))
            #:ttl 0)))

      (n-par-for-each
       1
       (lambda (branch)
         (let ((branch-name
                (assoc-ref branch "name")))
           (simple-format (current-error-port)
                          "refreshing data for ~A branch\n"
                          branch-name)

           (let ((derivation-changes
                  (with-exception-handler
                      (lambda (exn)
                        (simple-format
                         (current-error-port)
                         "failed fetching derivation changes for branch ~A: ~A\n"
                         branch-name
                         exn)

                        #f)
                    (lambda ()
                      (let ((derivation-changes-url
                             (branch-derivation-changes-url
                              branch-name
                              #:systems %systems-to-submit-builds-for)))

                        (with-sqlite-cache
                         database
                         'branch-derivation-changes
                         branch-derivation-changes
                         #:args
                         (list derivation-changes-url)
                         #:ttl (/ frequency 2))))
                    #:unwind? #t)))
             #f)))
       branches)))

  (call-with-new-thread
   (lambda ()
     (while #t
       (let ((start-time (current-time)))
         (with-exception-handler
             (lambda (exn)
               (simple-format
                (current-error-port)
                "exception in branch data refresh thread: ~A\n"
                exn))
           (lambda ()
             (with-time-logging "refreshing branch data"
               (with-throw-handler #t
                 refresh-data
                 (lambda args
                   (display (backtrace) (current-error-port))
                   (newline (current-error-port))))))
           #:unwind? #t)

         (let ((time-taken
                (- (current-time) start-time)))
           (if (>= time-taken frequency)
               (simple-format (current-error-port)
                              "warning: refreshing branch data is behind\n")
               (sleep
                (- frequency time-taken)))))))))