;;; 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 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 handle-doc-assets (if (string-prefix? (%store-prefix) doc-dir) (static-asset-from-store-renderer doc-dir) (static-asset-from-directory-renderer doc-dir))) (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 (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 " " 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) " QA Reviewed ") ((eq? overall-status 'important-checks-passing) " QA Succeeding ") ((eq? overall-status 'failed-to-apply-patches) " QA Investigate ") ((eq? overall-status 'large-number-of-builds) " QA Investigate ") ((eq? overall-status 'waiting-for-build-results) " QA Pending ") ((eq? overall-status 'guix-data-service-failed) " QA Investigate ") ((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 #: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)))) (('GET (and "qa-information-flow.png" filename)) (or (handle-doc-assets filename (request-headers request)) (list (build-response #:code 404) (string-append "Resource not found: " (uri->string (request-uri request)))))) ((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))) (call-with-delay-logging controller #:threshold 30 #:args (list 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?)))