;;; 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 manage-builds)
#: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-data-thread))
(define (make-controller assets-directory database metrics-registry)
(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)
200)
(take sorted-latest-series 200)
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=\"20\">
<clipPath id=\"clip\">
<rect width=\"140\" height=\"20\" 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=\"12\" text-anchor=\"middle\">
<rect width=\"40\" height=\"20\" fill=\"url(#job)\"/>
<text x=\"20\" y=\"14\" fill=\"#fff\">QA</text>
<rect x=\"40\" width=\"100\" height=\"20\" fill=\"url(#status)\"/>
<text x=\"90\" y=\"14\" fill=\"#000\">succeeding</text>
</g>
</svg>")
((eq? overall-status 'important-checks-failing)
"
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"20\">
<clipPath id=\"clip\">
<rect width=\"100\" height=\"20\" 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=\"firebrick\" />
</linearGradient>
<g clip-path=\"url(#clip)\" font-family=\"DejaVu Sans,Verdana,sans-serif\" font-size=\"12\" text-anchor=\"middle\">
<rect width=\"40\" height=\"20\" fill=\"url(#job)\"/>
<text x=\"20\" y=\"14\" fill=\"#fff\">QA</text>
<rect x=\"40\" width=\"60\" height=\"20\" fill=\"url(#status)\"/>
<text x=\"70\" y=\"14\" fill=\"#000\">failing</text>
</g>
</svg>")
(else
"
<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"272\" height=\"20\">
<clipPath id=\"clip\">
<rect width=\"100\" height=\"20\" 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=\"12\" text-anchor=\"middle\">
<rect width=\"40\" height=\"20\" fill=\"url(#job)\"/>
<text x=\"20\" y=\"14\" fill=\"#fff\">QA</text>
<rect x=\"40\" width=\"60\" height=\"20\" fill=\"url(#status)\"/>
<text x=\"70\" y=\"14\" 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 ((derivation-changes
change-details
(call-with-values
(lambda ()
(and=> (patch-series-derivation-changes-url
(with-sqlite-cache
database
'patchwork-patch-checks
patchwork-patch-checks
#:args (list
(assoc-ref (first (assoc-ref series "patches"))
"checks"))
#:ttl 1200)
#:systems %systems-to-submit-builds-for)
(lambda (url)
(with-sqlite-cache
database
'derivation-changes
patch-series-derivation-changes
#:args (list url)
#:ttl 6000))))
(lambda res
(match res
((#f)
(values #f #f))
(_ (apply values res))))))
(comparison-details
(and=>
(patch-series-compare-url series)
(lambda (url)
(with-sqlite-cache
database
'lint-warnings
patch-series-comparison
#:args
(list url)
#:ttl 6000)))))
(render-html
#:sxml (issue-view number
series
(assq-ref (assq-ref series 'mumi)
'tags)
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)
(define controller
(make-controller assets-directory database metrics-registry))
(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-data-thread database)
(define number-of-series-to-refresh 300)
(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 0))
(series-to-refresh
(if (> (length latest-series)
number-of-series-to-refresh)
(take latest-series number-of-series-to-refresh)
latest-series)))
(n-par-for-each
2
(lambda (series)
(let ((derivation-changes
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"failed fetching derivation changes for issue ~A: ~A\n"
(car series)
exn)
#f)
(lambda ()
(and=>
(patch-series-derivation-changes-url
(with-sqlite-cache
database
'patchwork-patch-checks
patchwork-patch-checks
#:args (list
(assoc-ref (first (assoc-ref series "patches"))
"checks"))
#:ttl 0)
#:systems %systems-to-submit-builds-for)
(lambda (url)
(with-sqlite-cache
database
'derivation-changes
patch-series-derivation-changes
#:args (list url)
#:ttl (* 60 20)))))
#: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 ()
(define frequency
(* 10 60))
(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)))))))))