diff options
Diffstat (limited to 'guix-qa-frontpage/server.scm')
| -rw-r--r-- | guix-qa-frontpage/server.scm | 214 |
1 files changed, 136 insertions, 78 deletions
diff --git a/guix-qa-frontpage/server.scm b/guix-qa-frontpage/server.scm index 8db6aae..4beaf09 100644 --- a/guix-qa-frontpage/server.scm +++ b/guix-qa-frontpage/server.scm @@ -32,17 +32,21 @@ #:use-module (fibers) #:use-module (fibers scheduler) #:use-module (fibers conditions) + #:use-module (knots) + #:use-module (knots web-server) + #:use-module (knots parallelism) #:use-module (guix store) + #:use-module (knots web-server) #:use-module ((guix build syscalls) #:select (set-thread-name)) + #:use-module ((guix-data-service utils) + #:select (delete-duplicates/sort!)) #: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 - call-with-delay-logging)) - #:use-module ((guix-build-coordinator utils fibers) - #:select (run-server/patched call-with-sigint)) + call-with-delay-logging)) #:use-module (guix-qa-frontpage database) #:use-module (guix-qa-frontpage derivation-changes) #:use-module (guix-qa-frontpage reproducible-builds) @@ -52,6 +56,7 @@ #:use-module (guix-qa-frontpage branch) #:use-module (guix-qa-frontpage package) #:use-module (guix-qa-frontpage issue) + #:use-module (guix-qa-frontpage utils) #:use-module (guix-qa-frontpage git-repository) #:use-module (guix-qa-frontpage manage-builds) #:use-module (guix-qa-frontpage manage-patch-branches) @@ -151,21 +156,32 @@ #:code 200 #:headers '((content-type . (text/plain)) (vary . (accept)))) - (lambda (port) - (write-metrics metrics-registry port) - (write-metrics plain-metrics-registry port)))) + (call-with-output-string + (lambda (port) + (write-metrics metrics-registry port) + (write-metrics plain-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)))) + 'list-non-master-branches + list-non-master-branches + #:ttl 300))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((branches . ,(list->vector + (map (match-lambda + ((name . details) + `((name . ,name) + ,@details))) + branches)))))) + (else + (render-html + #:sxml + (branches-view branches)))))) (('GET "branch" "master") (let ((substitute-availability systems-with-low-substitute-availability @@ -182,7 +198,7 @@ package-reproducibility)))) (('GET "branch" branch) (let ((revisions - derivation-changes + derivation-changes-counts substitute-availability package-reproducibility up-to-date-with-master @@ -207,25 +223,33 @@ #:sxml (branch-view branch revisions - derivation-changes + derivation-changes-counts 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))) + (let* ((revisions + derivation-changes-counts + substitute-availability + package-reproducibility + up-to-date-with-master + (with-sqlite-cache + database + 'branch-data + branch-data + #:args + (list branch) + #:version 3 + #:ttl 6000)) + (derivation-changes + (with-sqlite-cache + database + 'branch-derivation-changes-data + branch-derivation-changes-data/all-systems + #:args + (list revisions) + #:ttl 6000))) (render-html #:sxml (branch-package-changes-view branch @@ -260,16 +284,13 @@ 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<?)) + (reverse + (delete-duplicates/sort! + (map (lambda (series) + (assq-ref series 'branch)) + latest-series) + string<?))) (filtered-branches (filter-map (match-lambda @@ -280,7 +301,7 @@ query-params)) (latest-series-with-overall-statuses (filter-map - (lambda (series branch) + (lambda (series) (let ((overall-status (with-sqlite-cache database @@ -288,7 +309,9 @@ (const 'unknown) #:store-computed-value? #f #:args (list (first series)) - #:ttl 3600))) + #:ttl 3600)) + (branch + (assq-ref series 'branch))) (if (and (or (null? filtered-statuses) (member overall-status filtered-statuses)) @@ -298,8 +321,7 @@ `((branch . ,branch) (overall-status . ,overall-status))) #f))) - latest-series - latest-series-branches)) + latest-series)) (sorted-latest-series (sort latest-series-with-overall-statuses @@ -593,13 +615,12 @@ </svg>")) 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)))) + (let ((series (with-sqlite-cache + database + 'latest-patchwork-series-for-issue + latest-patchwork-series-for-issue + #:args (list (string->number number)) + #:ttl 1800))) (if series (let* ((base-and-target-refs derivation-changes @@ -619,8 +640,6 @@ (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 @@ -633,7 +652,7 @@ (render-html #:sxml (issue-view number series - branch + (assq-ref series 'branch) (assq-ref (assq-ref series 'mumi) 'tags) base-and-target-refs @@ -772,6 +791,13 @@ has no patches or has been closed.") (render-html #:sxml (package-view package-data)))) + (('GET "robots") ; robots.txt + (render-text + "User-agent: * +Disallow: /patches +Disallow: /issue +")) + (('GET "README") (let ((filename (string-append doc-dir "/README.html"))) (if (file-exists? filename) @@ -804,27 +830,23 @@ has no patches or has been closed.") (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)))) + (let ((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)))) (define* (start-guix-qa-frontpage port host assets-directory database metrics-registry #:key (controller-args '()) submit-builds? + manage-patch-branches? patch-issues-to-show generate-reproducible.json) (define controller @@ -834,6 +856,11 @@ has no patches or has been closed.") (when generate-reproducible.json (start-generate-reproducible.json-thread)) + (when manage-patch-branches? + (start-manage-patch-branches-thread database + metrics-registry + #:series-count patch-issues-to-show)) + (let ((finished? (make-condition))) (call-with-new-thread (lambda () @@ -844,14 +871,37 @@ has no patches or has been closed.") (run-fibers (lambda () + (start-refresh-patch-branches-data-fiber + database + metrics-registry + #:number-of-series-to-refresh patch-issues-to-show) + + (start-refresh-non-patch-branches-data-fiber database + metrics-registry) + (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)) + (parameterize + ((%fiberized-submit-build + (fiberize (lambda args + (call-with-duration-metric + metrics-registry + "submit_build_duration_seconds" + (lambda () + (apply submit-build args)))) + #:parallelism 8))) + + (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) + (start-submit-branch-builds-fiber database + "http://127.0.0.1:8746" + "https://data.qa.guix.gnu.org" + metrics-registry))) (wait finished?)) + #:hz 0 #:parallelism 1))) (call-with-sigint @@ -874,12 +924,20 @@ has no patches or has been closed.") (iota (length schedulers)) schedulers)) - (run-server/patched - (lambda (request body) - (apply values (handler request body controller))) + (run-knots-web-server + (lambda (request) + (apply values (handler request + (read-request-body request) + controller))) + #:exception-handler + (lambda (exn) + (apply values + (render-html #:sxml (error-page exn) + #:code 500))) #:host host #:port port) (wait finished?)) - #:parallelism 2)) + #:hz 0 + #:parallelism 1)) finished?))) |