;;; Guix QA Frontpage ;;; ;;; Copyright © 2022 Christopher Baines ;;; ;;; 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 ;;; . (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 " " 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) " QA Succeeding ") ((eq? overall-status 'needs-looking-at) " QA Investigate ") ((eq? overall-status 'important-checks-failing) " QA Failing ") (else " QA Unknown ")) 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)))))))))