diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm index 8eb5e7a..9c185c6 100644 --- a/guix-data-service/web/build-server/controller.scm +++ b/guix-data-service/web/build-server/controller.scm @@ -20,6 +20,7 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (json) + #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) #:use-module (guix-data-service web query-parameters) @@ -36,7 +37,6 @@ #:export (build-server-controller)) (define (render-build mime-types - conn build-server-id query-parameters) (if (any-invalid-query-parameters? query-parameters) @@ -56,15 +56,18 @@ (build-server-build-id (assq-ref query-parameters 'build_server_build_id)) (build - (if build-server-build-id - (select-build-by-build-server-and-build-server-build-id - conn - build-server-id - build-server-build-id) - (select-build-by-build-server-and-derivation-file-name - conn - build-server-id - derivation-file-name)))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (if build-server-build-id + (select-build-by-build-server-and-build-server-build-id + conn + build-server-id + build-server-build-id) + (select-build-by-build-server-and-derivation-file-name + conn + build-server-id + derivation-file-name))))))) (if build (render-html #:sxml @@ -80,10 +83,13 @@ ; guix-build-coordinator ; doesn't mark builds as ; failed-dependency - (select-required-builds-that-failed - conn - build-server-id - derivation-file-name) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-required-builds-that-failed + conn + build-server-id + derivation-file-name)))) #f))))) (render-html #:sxml (general-not-found @@ -106,12 +112,11 @@ (define (handle-build-event-submission parsed-query-parameters build-server-id-string body - conn secret-key-base) (define build-server-id (string->number build-server-id-string)) - (define (handle-derivation-events items) + (define (handle-derivation-events conn items) (unless (null? items) (let ((build-ids (insert-builds conn @@ -132,30 +137,38 @@ items))))) (define (process-items items) - (with-postgresql-transaction - conn - (lambda (conn) - (handle-derivation-events - (filter (lambda (item) - (let ((type (assoc-ref item "type"))) - (if type - (string=? type "build") - (begin - (simple-format (current-error-port) - "warning: unknown type for event: ~A\n" - item) - #f)))) - items))))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (with-postgresql-transaction + conn + (lambda (conn) + (handle-derivation-events + conn + (filter (lambda (item) + (let ((type (assoc-ref item "type"))) + (if type + (string=? type "build") + (begin + (simple-format + (current-error-port) + "warning: unknown type for event: ~A\n" + item) + #f)))) + items)))))))) (if (any-invalid-query-parameters? parsed-query-parameters) (render-json '((error . "no token provided")) #:code 400) (let ((provided-token (assq-ref parsed-query-parameters 'token)) - (permitted-tokens (compute-tokens-for-build-server - conn - secret-key-base - build-server-id))) + (permitted-tokens + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (compute-tokens-for-build-server conn + secret-key-base + build-server-id)))))) (if (member provided-token (map cdr permitted-tokens) string=?) @@ -201,25 +214,32 @@ '((error . "error")) #:code 403))))) -(define (handle-signing-key-request conn id) +(define (handle-signing-key-request id) (render-html #:sxml (view-signing-key - (select-signing-key conn id)))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-signing-key conn id))))))) (define (build-server-controller request method-and-path-components mime-types body - conn secret-key-base) (match method-and-path-components (('GET "build-servers") - (let ((build-servers (select-build-servers conn))) + (letpar& ((build-servers + (with-thread-postgresql-connection + select-build-servers))) (render-build-servers mime-types build-servers))) (('GET "build-server" build-server-id) - (let ((build-server (select-build-server conn (string->number - build-server-id)))) + (letpar& ((build-server + (with-thread-postgresql-connection + (lambda (conn) + (select-build-server conn (string->number + build-server-id)))))) (if build-server (render-build-server mime-types build-server) @@ -231,7 +251,6 @@ `((derivation_file_name ,identity) (build_server_build_id ,identity))))) (render-build mime-types - conn (string->number build-server-id) parsed-query-parameters))) (('POST "build-server" build-server-id "build-events") @@ -242,9 +261,7 @@ (handle-build-event-submission parsed-query-parameters build-server-id body - conn secret-key-base))) (('GET "build-server" "signing-key" id) - (handle-signing-key-request conn - (string->number id))) + (handle-signing-key-request (string->number id))) (_ #f))) diff --git a/guix-data-service/web/build/controller.scm b/guix-data-service/web/build/controller.scm index 78a89e7..b573a26 100644 --- a/guix-data-service/web/build/controller.scm +++ b/guix-data-service/web/build/controller.scm @@ -18,6 +18,8 @@ (define-module (guix-data-service web build controller) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (guix-data-service utils) + #:use-module (guix-data-service database) #:use-module (guix-data-service web render) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service model build) @@ -34,9 +36,11 @@ (string-append "unknown build status: " status)))) -(define (parse-build-server conn) +(define parse-build-server (lambda (v) - (let ((build-servers (select-build-servers conn))) + (letpar& ((build-servers + (with-thread-postgresql-connection + select-build-servers))) (or (any (match-lambda ((id url lookup-all-derivations? lookup-builds?) (if (eq? (string->number v) @@ -51,21 +55,19 @@ (define (build-controller request method-and-path-components mime-types - body - conn) + body) (match method-and-path-components (('GET "builds") (render-builds request - mime-types - conn)) + mime-types)) (_ #f))) -(define (render-builds request mime-types conn) +(define (render-builds request mime-types) (let ((parsed-query-parameters (parse-query-parameters request `((build_status ,parse-build-status #:multi-value) - (build_server ,(parse-build-server conn) #:multi-value))))) + (build_server ,parse-build-server #:multi-value))))) (if (any-invalid-query-parameters? parsed-query-parameters) (render-html #:sxml (view-builds parsed-query-parameters @@ -73,20 +75,29 @@ '() '() '())) - (render-html - #:sxml (view-builds parsed-query-parameters - build-status-strings - (map (match-lambda - ((id url lookup-all-derivations lookup-builds) - (cons url id))) - (select-build-servers conn)) - (select-build-stats - conn - (assq-ref parsed-query-parameters - 'build_server)) - (select-builds-with-context - conn - (assq-ref parsed-query-parameters - 'build_status) - (assq-ref parsed-query-parameters - 'build_server))))))) + (letpar& ((build-servers + (with-thread-postgresql-connection + select-build-servers)) + (build-stats + (with-thread-postgresql-connection + (lambda (conn) + (select-build-stats + conn + (assq-ref parsed-query-parameters + 'build_server))))) + (builds-with-context + (with-thread-postgresql-connection + (lambda (conn) + (select-builds-with-context + conn + (assq-ref parsed-query-parameters + 'build_status) + (assq-ref parsed-query-parameters + 'build_server)))))) + + (render-html + #:sxml (view-builds parsed-query-parameters + build-status-strings + build-servers + build-stats + builds-with-context)))))) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index c3db5e2..636de67 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -23,6 +23,8 @@ #:use-module (texinfo) #:use-module (texinfo html) #:use-module (texinfo plain-text) + #:use-module (guix-data-service utils) + #:use-module (guix-data-service database) #:use-module (guix-data-service web sxml) #:use-module (guix-data-service web util) #:use-module (guix-data-service web render) @@ -48,35 +50,37 @@ (define (parse-build-status s) s) -(define (parse-commit conn) - (lambda (s) - (if (guix-commit-exists? conn s) - s - (make-invalid-query-parameter - s "unknown commit")))) +(define (parse-commit s) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn s)))) + s + (make-invalid-query-parameter + s "unknown commit"))) -(define (parse-derivation conn) - (lambda (file-name) - (if (select-derivation-by-file-name conn file-name) - file-name - (make-invalid-query-parameter - file-name "unknown derivation")))) +(define (parse-derivation file-name) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-by-file-name conn file-name)))) + file-name + (make-invalid-query-parameter + file-name "unknown derivation"))) (define (compare-controller request method-and-path-components mime-types - body - conn) + body) (match method-and-path-components (('GET "compare") (let* ((parsed-query-parameters (parse-query-parameters request - `((base_commit ,(parse-commit conn) #:required) - (target_commit ,(parse-commit conn) #:required) + `((base_commit ,parse-commit #:required) + (target_commit ,parse-commit #:required) (locale ,identity #:default "en_US.UTF-8"))))) (render-compare mime-types - conn parsed-query-parameters))) (('GET "compare-by-datetime") (let* ((parsed-query-parameters @@ -88,28 +92,25 @@ (target_datetime ,parse-datetime #:required) (locale ,identity #:default "en_US.UTF-8"))))) (render-compare-by-datetime mime-types - conn parsed-query-parameters))) (('GET "compare" "derivation") (let* ((parsed-query-parameters (parse-query-parameters request - `((base_derivation ,(parse-derivation conn) #:required) - (target_derivation ,(parse-derivation conn) #:required))))) + `((base_derivation ,parse-derivation #:required) + (target_derivation ,parse-derivation #:required))))) (render-compare/derivation mime-types - conn parsed-query-parameters))) (('GET "compare" "derivations") (let* ((parsed-query-parameters (parse-query-parameters request - `((base_commit ,(parse-commit conn) #:required) - (target_commit ,(parse-commit conn) #:required) + `((base_commit ,parse-commit #:required) + (target_commit ,parse-commit #:required) (system ,parse-system #:multi-value) (target ,parse-target #:multi-value) (build_status ,parse-build-status #:multi-value))))) (render-compare/derivations mime-types - conn parsed-query-parameters))) (('GET "compare-by-datetime" "derivations") (let* ((parsed-query-parameters @@ -126,17 +127,15 @@ '((base_commit base_datetime) (target_commit target_datetime))))) (render-compare-by-datetime/derivations mime-types - conn parsed-query-parameters))) (('GET "compare" "packages") (let* ((parsed-query-parameters (parse-query-parameters request - `((base_commit ,(parse-commit conn) #:required) - (target_commit ,(parse-commit conn) #:required))))) + `((base_commit ,parse-commit #:required) + (target_commit ,parse-commit #:required))))) (render-compare/packages mime-types - conn - parsed-query-parameters))) + parsed-query-parameters))) (_ #f))) (define (texinfo->variants-alist s) @@ -148,16 +147,7 @@ (plain . ,(stexi->plain-text stexi))))) (define (render-compare mime-types - conn query-parameters) - (define lint-warnings-locale-options - (map - (match-lambda - ((locale) - locale)) - (lint-warning-message-locales-for-revision - conn (assq-ref query-parameters 'target_commit)))) - (if (any-invalid-query-parameters? query-parameters) (case (most-appropriate-mime-type '(application/json text/html) @@ -166,195 +156,79 @@ (render-json '((error . "invalid query")))) (else - (render-html - #:sxml (compare-invalid-parameters - query-parameters - (match (assq-ref query-parameters 'base_commit) - (($ value) - (select-job-for-commit conn value)) - (_ #f)) - (match (assq-ref query-parameters 'target_commit) - (($ value) - (select-job-for-commit conn value)) - (_ #f)))))) + (letpar& ((base-job + (match (assq-ref query-parameters 'base_commit) + (($ value) + (with-thread-postgresql-connection + (lambda (conn) + (select-job-for-commit conn value)))) + (_ #f))) + (target-job + (match (assq-ref query-parameters 'target_commit) + (($ value) + (with-thread-postgresql-connection + (lambda (conn) + (select-job-for-commit conn value)))) + (_ #f)))) + (render-html + #:sxml (compare-invalid-parameters + query-parameters + base-job + target-job))))) - (let ((base-revision-id (commit->revision-id - conn - (assq-ref query-parameters 'base_commit))) - (target-revision-id (commit->revision-id - conn - (assq-ref query-parameters 'target_commit))) - (locale (assq-ref query-parameters 'locale))) + (letpar& ((base-revision-id + (with-thread-postgresql-connection + (lambda (conn) + (commit->revision-id + conn + (assq-ref query-parameters 'base_commit))))) + (target-revision-id + (with-thread-postgresql-connection + (lambda (conn) + (commit->revision-id + conn + (assq-ref query-parameters 'target_commit))))) + (locale + (assq-ref query-parameters 'locale))) (let-values (((base-packages-vhash target-packages-vhash) (package-data->package-data-vhashes - (package-differences-data conn - base-revision-id - target-revision-id)))) - (let* ((new-packages - (package-data-vhashes->new-packages base-packages-vhash - target-packages-vhash)) - (removed-packages - (package-data-vhashes->removed-packages base-packages-vhash - target-packages-vhash)) - (version-changes - (package-data-version-changes base-packages-vhash - target-packages-vhash)) - (lint-warnings-data - (group-list-by-first-n-fields - 2 - (lint-warning-differences-data conn - base-revision-id - target-revision-id - locale))) - (channel-news-data - (channel-news-differences-data conn - base-revision-id - target-revision-id))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((channel-news . ,(list->vector - (map - (match-lambda - ((commit tag title_text body_text change) - `(,@(if (null? commit) - '() - `((commit . ,commit))) - ,@(if (null? tag) - '() - `((tag . ,tag))) - (title-text - . ,(map - (match-lambda - ((lang . text) - (cons - lang - (texinfo->variants-alist text)))) - title_text)) - (body-text - . ,(map - (match-lambda - ((lang . text) - (cons - lang - (texinfo->variants-alist text)))) - body_text)) - (change . ,change)))) - channel-news-data))) - (new-packages . ,(list->vector new-packages)) - (removed-packages . ,(list->vector removed-packages)) - (version-changes . ,(list->vector - (map - (match-lambda - ((name data ...) - `((name . ,name) - ,@data))) - version-changes)))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare query-parameters - (guix-revisions-cgit-url-bases - conn - (list base-revision-id - target-revision-id)) - new-packages - removed-packages - version-changes - lint-warnings-data - lint-warnings-locale-options - channel-news-data) - #:extra-headers http-headers-for-unchanging-content)))))))) - -(define (render-compare-by-datetime mime-types - conn - query-parameters) - (if (any-invalid-query-parameters? query-parameters) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - '((error . "invalid query")))) - (else - (render-html - #:sxml (compare-invalid-parameters - query-parameters - (match (assq-ref query-parameters 'base_commit) - (($ value) - (select-job-for-commit conn value)) - (_ #f)) - (match (assq-ref query-parameters 'target_commit) - (($ value) - (select-job-for-commit conn value)) - (_ #f)))))) - - (let ((base-branch (assq-ref query-parameters 'base_branch)) - (base-datetime (assq-ref query-parameters 'base_datetime)) - (target-branch (assq-ref query-parameters 'target_branch)) - (target-datetime (assq-ref query-parameters 'target_datetime)) - (locale (assq-ref query-parameters 'locale))) - (let* ((base-revision-details - (select-guix-revision-for-branch-and-datetime conn - base-branch - base-datetime)) - (lint-warnings-locale-options - (map - (match-lambda - ((locale) - locale)) - (lint-warning-message-locales-for-revision - conn (second base-revision-details)))) - (base-revision-id - (first base-revision-details)) - (target-revision-details - (select-guix-revision-for-branch-and-datetime conn - target-branch - target-datetime)) - (target-revision-id - (first target-revision-details))) - (let-values - (((base-packages-vhash target-packages-vhash) - (package-data->package-data-vhashes - (package-differences-data conn - base-revision-id - target-revision-id)))) - (let* ((new-packages - (package-data-vhashes->new-packages base-packages-vhash - target-packages-vhash)) - (removed-packages - (package-data-vhashes->removed-packages base-packages-vhash - target-packages-vhash)) - (version-changes - (package-data-version-changes base-packages-vhash - target-packages-vhash)) - (lint-warnings-data - (group-list-by-first-n-fields - 2 - (lint-warning-differences-data conn - base-revision-id - target-revision-id - locale))) - (channel-news-data - (channel-news-differences-data conn - base-revision-id - target-revision-id))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (package-differences-data conn + base-revision-id + target-revision-id))))))) + (let ((new-packages + (package-data-vhashes->new-packages base-packages-vhash + target-packages-vhash)) + (removed-packages + (package-data-vhashes->removed-packages base-packages-vhash + target-packages-vhash)) + (version-changes + (package-data-version-changes base-packages-vhash + target-packages-vhash))) + (letpar& ((lint-warnings-data + (with-thread-postgresql-connection + (lambda (conn) + (group-list-by-first-n-fields + 2 + (lint-warning-differences-data conn + base-revision-id + target-revision-id + locale))))) + (channel-news-data + (with-thread-postgresql-connection + (lambda (conn) + (channel-news-differences-data conn + base-revision-id + target-revision-id))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) ((application/json) (render-json - `((revisions - . ((base - . ((commit . ,(second base-revision-details)) - (datetime . ,(fifth base-revision-details)))) - (target - . ((commit . ,(second target-revision-details)) - (datetime . ,(fifth target-revision-details)))))) - (channel-news . ,(list->vector + `((channel-news . ,(list->vector (map (match-lambda ((commit tag title_text body_text change) @@ -393,24 +267,202 @@ version-changes)))) #:extra-headers http-headers-for-unchanging-content)) (else - (render-html - #:sxml (compare `(,@query-parameters - (base_commit . ,(second base-revision-details)) - (target_commit . ,(second target-revision-details))) - (guix-revisions-cgit-url-bases - conn - (list base-revision-id - target-revision-id)) - new-packages - removed-packages - version-changes - lint-warnings-data - lint-warnings-locale-options - channel-news-data) - #:extra-headers http-headers-for-unchanging-content))))))))) + (letpar& ((lint-warnings-locale-options + (map + (match-lambda + ((locale) + locale)) + (with-thread-postgresql-connection + (lambda (conn) + (lint-warning-message-locales-for-revision + conn + (assq-ref query-parameters 'target_commit)))))) + (cgit-url-bases + (with-thread-postgresql-connection + (lambda (conn) + (guix-revisions-cgit-url-bases + conn + (list base-revision-id + target-revision-id)))))) + (render-html + #:sxml (compare query-parameters + cgit-url-bases + new-packages + removed-packages + version-changes + lint-warnings-data + lint-warnings-locale-options + channel-news-data) + #:extra-headers http-headers-for-unchanging-content)))))))))) + +(define (render-compare-by-datetime mime-types + query-parameters) + (if (any-invalid-query-parameters? query-parameters) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + '((error . "invalid query")))) + (else + (letpar& ((base-job + (match (assq-ref query-parameters 'base_commit) + (($ value) + (with-thread-postgresql-connection + (lambda (conn) + (select-job-for-commit conn value)))) + (_ #f))) + (target-job + (match (assq-ref query-parameters 'target_commit) + (($ value) + (with-thread-postgresql-connection + (lambda (conn) + (select-job-for-commit conn value)))) + (_ #f)))) + (render-html + #:sxml (compare-invalid-parameters + query-parameters + base-job + target-job))))) + + (let ((base-branch (assq-ref query-parameters 'base_branch)) + (base-datetime (assq-ref query-parameters 'base_datetime)) + (target-branch (assq-ref query-parameters 'target_branch)) + (target-datetime (assq-ref query-parameters 'target_datetime)) + (locale (assq-ref query-parameters 'locale))) + (letpar& ((base-revision-details + (with-thread-postgresql-connection + (lambda (conn) + (select-guix-revision-for-branch-and-datetime + conn + base-branch + base-datetime)))) + (target-revision-details + (with-thread-postgresql-connection + (lambda (conn) + (select-guix-revision-for-branch-and-datetime + conn + target-branch + target-datetime))))) + (letpar& ((lint-warnings-locale-options + (map + (match-lambda + ((locale) + locale)) + (with-thread-postgresql-connection + (lambda (conn) + (lint-warning-message-locales-for-revision + conn + (second base-revision-details))))))) + (let ((base-revision-id + (first base-revision-details)) + (target-revision-id + (first target-revision-details))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-data->package-data-vhashes + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (package-differences-data conn + base-revision-id + target-revision-id))))))) + (let* ((new-packages + (package-data-vhashes->new-packages base-packages-vhash + target-packages-vhash)) + (removed-packages + (package-data-vhashes->removed-packages base-packages-vhash + target-packages-vhash)) + (version-changes + (package-data-version-changes base-packages-vhash + target-packages-vhash)) + (channel-news-data + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (channel-news-differences-data conn + base-revision-id + target-revision-id)))))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((revisions + . ((base + . ((commit . ,(second base-revision-details)) + (datetime . ,(fifth base-revision-details)))) + (target + . ((commit . ,(second target-revision-details)) + (datetime . ,(fifth target-revision-details)))))) + (channel-news . ,(list->vector + (map + (match-lambda + ((commit tag title_text body_text change) + `(,@(if (null? commit) + '() + `((commit . ,commit))) + ,@(if (null? tag) + '() + `((tag . ,tag))) + (title-text + . ,(map + (match-lambda + ((lang . text) + (cons + lang + (texinfo->variants-alist text)))) + title_text)) + (body-text + . ,(map + (match-lambda + ((lang . text) + (cons + lang + (texinfo->variants-alist text)))) + body_text)) + (change . ,change)))) + channel-news-data))) + (new-packages . ,(list->vector new-packages)) + (removed-packages . ,(list->vector removed-packages)) + (version-changes . ,(list->vector + (map + (match-lambda + ((name data ...) + `((name . ,name) + ,@data))) + version-changes)))) + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare `(,@query-parameters + (base_commit . ,(second base-revision-details)) + (target_commit . ,(second target-revision-details))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-revisions-cgit-url-bases + conn + (list base-revision-id + target-revision-id))))) + new-packages + removed-packages + version-changes + (parallel-via-thread-pool-channel + (group-list-by-first-n-fields + 2 + (with-thread-postgresql-connection + (lambda (conn) + (lint-warning-differences-data + conn + base-revision-id + target-revision-id + locale))))) + lint-warnings-locale-options + channel-news-data) + #:extra-headers http-headers-for-unchanging-content))))))))))) (define (render-compare/derivation mime-types - conn query-parameters) (if (any-invalid-query-parameters? query-parameters) (case (most-appropriate-mime-type @@ -427,10 +479,12 @@ (let ((base-derivation (assq-ref query-parameters 'base_derivation)) (target-derivation (assq-ref query-parameters 'target_derivation))) - (let ((data - (derivation-differences-data conn - base-derivation - target-derivation))) + (letpar& ((data + (with-thread-postgresql-connection + (lambda (conn) + (derivation-differences-data conn + base-derivation + target-derivation))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -446,7 +500,6 @@ #:extra-headers http-headers-for-unchanging-content))))))) (define (render-compare/derivations mime-types - conn query-parameters) (define (derivations->alist derivations) (map (match-lambda @@ -470,7 +523,8 @@ (render-html #:sxml (compare/derivations query-parameters - (valid-systems conn) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection valid-systems)) build-status-strings '())))) @@ -479,41 +533,42 @@ (systems (assq-ref query-parameters 'system)) (targets (assq-ref query-parameters 'target)) (build-statuses (assq-ref query-parameters 'build_status))) - (let* - ((data - (package-derivation-differences-data - conn - (commit->revision-id conn base-commit) - (commit->revision-id conn target-commit) - #:systems systems - #:targets targets)) - (names-and-versions - (package-derivation-data->names-and-versions data))) - (let-values - (((base-packages-vhash target-packages-vhash) - (package-derivation-data->package-derivation-data-vhashes data))) - (let ((derivation-changes - (package-derivation-data-changes names-and-versions - base-packages-vhash - target-packages-vhash))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - derivation-changes - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare/derivations - query-parameters - (valid-systems conn) - build-status-strings - derivation-changes) - #:extra-headers http-headers-for-unchanging-content))))))))) + (letpar& ((data + (with-thread-postgresql-connection + (lambda (conn) + (package-derivation-differences-data + conn + (commit->revision-id conn base-commit) + (commit->revision-id conn target-commit) + #:systems systems + #:targets targets))))) + (let ((names-and-versions + (package-derivation-data->names-and-versions data))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-derivation-data->package-derivation-data-vhashes data))) + (let ((derivation-changes + (package-derivation-data-changes names-and-versions + base-packages-vhash + target-packages-vhash))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + derivation-changes + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare/derivations + query-parameters + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection valid-systems)) + build-status-strings + derivation-changes) + #:extra-headers http-headers-for-unchanging-content)))))))))) (define (render-compare-by-datetime/derivations mime-types - conn query-parameters) (define (derivations->alist derivations) (map (match-lambda @@ -537,7 +592,8 @@ (render-html #:sxml (compare-by-datetime/derivations query-parameters - (valid-systems conn) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection valid-systems)) build-status-strings '() '() @@ -550,50 +606,58 @@ (systems (assq-ref query-parameters 'system)) (targets (assq-ref query-parameters 'target)) (build-statuses (assq-ref query-parameters 'build_status))) - (let* + (letpar& ((base-revision-details - (select-guix-revision-for-branch-and-datetime conn - base-branch - base-datetime)) + (with-thread-postgresql-connection + (lambda (conn) + (select-guix-revision-for-branch-and-datetime conn + base-branch + base-datetime)))) (target-revision-details - (select-guix-revision-for-branch-and-datetime conn - target-branch - target-datetime)) - (data - (package-derivation-differences-data conn - (first base-revision-details) - (first target-revision-details) - #:systems systems - #:targets targets)) - (names-and-versions - (package-derivation-data->names-and-versions data))) - (let-values - (((base-packages-vhash target-packages-vhash) - (package-derivation-data->package-derivation-data-vhashes data))) - (let ((derivation-changes - (package-derivation-data-changes names-and-versions - base-packages-vhash - target-packages-vhash))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - derivation-changes - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare-by-datetime/derivations - query-parameters - (valid-systems conn) - build-status-strings - base-revision-details - target-revision-details - derivation-changes) - #:extra-headers http-headers-for-unchanging-content))))))))) + (with-thread-postgresql-connection + (lambda (conn) + (select-guix-revision-for-branch-and-datetime conn + target-branch + target-datetime))))) + (letpar& + ((data + (with-thread-postgresql-connection + (lambda (conn) + (package-derivation-differences-data + conn + (first base-revision-details) + (first target-revision-details) + #:systems systems + #:targets targets))))) + (let ((names-and-versions + (package-derivation-data->names-and-versions data))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-derivation-data->package-derivation-data-vhashes data))) + (let ((derivation-changes + (package-derivation-data-changes names-and-versions + base-packages-vhash + target-packages-vhash))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + derivation-changes + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare-by-datetime/derivations + query-parameters + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection valid-systems)) + build-status-strings + base-revision-details + target-revision-details + derivation-changes) + #:extra-headers http-headers-for-unchanging-content))))))))))) (define (render-compare/packages mime-types - conn query-parameters) (define (package-data-vhash->json vh) (delete-duplicates @@ -612,29 +676,49 @@ (render-json '((error . "invalid query")))) (else + (letpar& ((base-job + (match (assq-ref query-parameters 'base_commit) + (($ value) + (with-thread-postgresql-connection + (lambda (conn) + (select-job-for-commit conn value)))) + (_ #f))) + (target-job + (match (assq-ref query-parameters 'target_commit) + (($ value) + (with-thread-postgresql-connection + (lambda (conn) + (select-job-for-commit conn value)))) + (_ #f)))) (render-html #:sxml (compare-invalid-parameters query-parameters - (match (assq-ref query-parameters 'base_commit) - (($ value) - (select-job-for-commit conn value)) - (_ #f)) - (match (assq-ref query-parameters 'target_commit) - (($ value) - (select-job-for-commit conn value)) - (_ #f)))))) + base-job + target-job))))) (let ((base-commit (assq-ref query-parameters 'base_commit)) (target-commit (assq-ref query-parameters 'target_commit))) - (let ((base-revision-id (commit->revision-id conn base-commit)) - (target-revision-id (commit->revision-id conn target-commit))) - + (letpar& ((base-revision-id + (with-thread-postgresql-connection + (lambda (conn) + (commit->revision-id + conn + base-commit)))) + (target-revision-id + (with-thread-postgresql-connection + (lambda (conn) + (commit->revision-id + conn + target-commit))))) (let-values (((base-packages-vhash target-packages-vhash) (package-data->package-data-vhashes - (package-differences-data conn - base-revision-id - target-revision-id)))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (package-differences-data conn + base-revision-id + target-revision-id))))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index a8a8696..cf751ad 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -19,6 +19,7 @@ (define-module (guix-data-service web controller) #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module (ice-9 threads) #:use-module (ice-9 pretty-print) #:use-module (ice-9 textual-ports) #:use-module (ice-9 string-fun) @@ -35,6 +36,7 @@ #:use-module (squee) #:use-module (json) #:use-module (prometheus) + #:use-module (guix-data-service utils) #:use-module (guix-data-service config) #:use-module (guix-data-service comparison) #:use-module (guix-data-service database) @@ -129,8 +131,20 @@ "_")) #:labels '(name)))) pg-stat-fields))) - (lambda (conn) - (let ((metric-values (fetch-high-level-table-size-metrics conn))) + (lambda () + (letpar& ((metric-values + (with-thread-postgresql-connection + fetch-high-level-table-size-metrics)) + (guix-revisions-count + (with-thread-postgresql-connection + count-guix-revisions)) + (pg-stat-user-tables-metrics + (with-thread-postgresql-connection + fetch-pg-stat-user-tables-metrics)) + (load-new-guix-revision-job-metrics + (with-thread-postgresql-connection + select-load-new-guix-revision-job-metrics))) + (for-each (match-lambda ((name row-estimate table-bytes index-bytes toast-bytes) @@ -146,54 +160,66 @@ (metric-set table-toast-bytes-metric toast-bytes #:label-values `((name . ,name))))) - metric-values)) + metric-values) - (metric-set revisions-count-metric - (count-guix-revisions conn)) + (metric-set revisions-count-metric + guix-revisions-count) - (map (lambda (field-values) - (let ((name (assq-ref field-values 'name))) - (for-each - (match-lambda - (('name . _) #f) - ((field . value) - (let ((metric (or (assq-ref pg-stat-metrics field) - (error field)))) - (metric-set metric - value - #:label-values `((name . ,name)))))) - field-values))) - (fetch-pg-stat-user-tables-metrics conn)) + (map (lambda (field-values) + (let ((name (assq-ref field-values 'name))) + (for-each + (match-lambda + (('name . _) #f) + ((field . value) + (let ((metric (or (assq-ref pg-stat-metrics field) + (error field)))) + (metric-set metric + value + #:label-values `((name . ,name)))))) + field-values))) + pg-stat-user-tables-metrics) - (for-each (match-lambda - ((repository-label completed count) - (metric-set - load-new-guix-revision-job-count - count - #:label-values - `((repository_label . ,repository-label) - (completed . ,(if completed "yes" "no")))))) - (select-load-new-guix-revision-job-metrics conn)) + (for-each (match-lambda + ((repository-label completed count) + (metric-set + load-new-guix-revision-job-count + count + #:label-values + `((repository_label . ,repository-label) + (completed . ,(if completed "yes" "no")))))) + load-new-guix-revision-job-metrics) - (list (build-response - #:code 200 - #:headers '((content-type . (text/plain)))) - (lambda (port) - (write-metrics registry port)))))) + (list (build-response + #:code 200 + #:headers '((content-type . (text/plain)))) + (lambda (port) + (write-metrics registry port))))))) + +(define (render-derivation derivation-file-name) + (letpar& ((derivation + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-by-file-name conn derivation-file-name))))) -(define (render-derivation conn derivation-file-name) - (let ((derivation (select-derivation-by-file-name conn - derivation-file-name))) (if derivation - (let ((derivation-inputs (select-derivation-inputs-by-derivation-id - conn - (first derivation))) - (derivation-outputs (select-derivation-outputs-by-derivation-id - conn - (first derivation))) - (builds (select-builds-with-context-by-derivation-file-name + (letpar& ((derivation-inputs + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-inputs-by-derivation-id conn - (second derivation)))) + (first derivation))))) + (derivation-outputs + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-outputs-by-derivation-id + conn + (first derivation))))) + (builds + (with-thread-postgresql-connection + (lambda (conn) + (select-builds-with-context-by-derivation-file-name + conn + (second derivation)))))) (render-html #:sxml (view-derivation derivation derivation-inputs @@ -207,19 +233,32 @@ "No derivation found with this file name.") #:code 404)))) -(define (render-json-derivation conn derivation-file-name) - (let ((derivation (select-derivation-by-file-name conn - derivation-file-name))) - (if derivation - (let ((derivation-inputs (select-derivation-inputs-by-derivation-id - conn - (first derivation))) - (derivation-outputs (select-derivation-outputs-by-derivation-id - conn - (first derivation))) - (derivation-sources (select-derivation-sources-by-derivation-id - conn - (first derivation)))) +(define (render-json-derivation derivation-file-name) + (let ((derivation + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-by-file-name conn + derivation-file-name)))))) + (if derivation + (letpar& ((derivation-inputs + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-inputs-by-derivation-id + conn + (first derivation))))) + (derivation-outputs + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-outputs-by-derivation-id + conn + (first derivation))))) + (derivation-sources + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-sources-by-derivation-id + conn + (first derivation)))))) (render-json `((inputs . ,(list->vector (map @@ -255,19 +294,35 @@ env-var)))))))) (render-json '((error . "invalid path")))))) -(define (render-formatted-derivation conn derivation-file-name) - (let ((derivation (select-derivation-by-file-name conn - derivation-file-name))) +(define (render-formatted-derivation derivation-file-name) + (let ((derivation + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-by-file-name conn + derivation-file-name)))))) (if derivation - (let ((derivation-inputs (select-derivation-inputs-by-derivation-id - conn - (first derivation))) - (derivation-outputs (select-derivation-outputs-by-derivation-id - conn - (first derivation))) - (derivation-sources (select-derivation-sources-by-derivation-id - conn - (first derivation)))) + (letpar& ((derivation-inputs + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-inputs-by-derivation-id + conn + (first derivation)))))) + (derivation-outputs + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-outputs-by-derivation-id + conn + (first derivation)))))) + (derivation-sources + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-sources-by-derivation-id + conn + (first derivation))))))) (render-html #:sxml (view-formatted-derivation derivation derivation-inputs @@ -281,10 +336,14 @@ "No derivation found with this file name.") #:code 404)))) -(define (render-narinfos conn filename) - (let ((narinfos (select-nars-for-output - conn - (string-append "/gnu/store/" filename)))) +(define (render-narinfos filename) + (let ((narinfos + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-nars-for-output + conn + (string-append "/gnu/store/" filename))))))) (if (null? narinfos) (render-html #:sxml (general-not-found @@ -295,11 +354,17 @@ (render-html #:sxml (view-narinfos narinfos))))) -(define (render-store-item conn filename) - (let ((derivation (select-derivation-by-output-filename conn filename))) +(define (render-store-item filename) + (letpar& ((derivation + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-by-output-filename conn filename))))) (match derivation (() - (match (select-derivation-source-file-by-store-path conn filename) + (match (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-source-file-by-store-path conn filename)))) (() (render-html #:sxml (general-not-found @@ -310,29 +375,52 @@ (render-html #:sxml (view-derivation-source-file filename - (select-derivation-source-file-nar-details-by-file-name conn - filename)) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-source-file-nar-details-by-file-name + conn + filename))))) #:extra-headers http-headers-for-unchanging-content)))) (derivations - (render-html - #:sxml (view-store-item filename - derivations - (map (lambda (derivation) - (match derivation - ((file-name output-id rest ...) - (select-derivations-using-output - conn output-id)))) - derivations) - (select-nars-for-output conn - filename) - (select-builds-with-context-by-derivation-output - conn filename))))))) + (letpar& ((derivations-using-store-item-list + (with-thread-postgresql-connection + (lambda (conn) + (map (lambda (derivation) + (match derivation + ((file-name output-id rest ...) + (select-derivations-using-output + conn output-id)))) + derivations)))) + (nars + (with-thread-postgresql-connection + (lambda (conn) + (select-nars-for-output conn filename)))) + (builds + (with-thread-postgresql-connection + (lambda (conn) + (select-builds-with-context-by-derivation-output + conn + filename))))) + (render-html + #:sxml (view-store-item filename + derivations + derivations-using-store-item-list + nars + builds))))))) -(define (render-json-store-item conn filename) - (let ((derivation (select-derivation-by-output-filename conn filename))) +(define (render-json-store-item filename) + (let ((derivation + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-by-output-filename conn filename)))))) (match derivation (() - (match (select-derivation-source-file-by-store-path conn filename) + (match (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-source-file-by-store-path conn filename)))) (() (render-json '((error . "store item not found")))) ((id) @@ -343,43 +431,54 @@ (match-lambda ((key . value) `((,key . ,value)))) - (select-derivation-source-file-nar-details-by-file-name - conn - filename))))))))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-source-file-nar-details-by-file-name + conn + filename)))))))))))) (derivations - (render-json - `((nars . ,(list->vector - (map - (match-lambda - ((_ hash _ urls signatures) - `((hash . ,hash) - (urls - . ,(list->vector - (map - (lambda (url-data) - `((size . ,(assoc-ref url-data "size")) - (compression . ,(assoc-ref url-data "compression")) - (url . ,(assoc-ref url-data "url")))) - urls))) - (signatures - . ,(list->vector - (map - (lambda (signature) - `((version . ,(assoc-ref signature "version")) - (host-name . ,(assoc-ref signature "host_name")))) - signatures)))))) - (select-nars-for-output conn filename)))) - (derivations - . ,(list->vector - (map - (match-lambda - ((filename output-id) - `((filename . ,filename) - (derivations-using-store-item - . ,(list->vector - (map car (select-derivations-using-output - conn output-id))))))) - derivations))))))))) + (letpar& ((nars + (with-thread-postgresql-connection + (lambda (conn) + (select-nars-for-output conn filename))))) + (render-json + `((nars . ,(list->vector + (map + (match-lambda + ((_ hash _ urls signatures) + `((hash . ,hash) + (urls + . ,(list->vector + (map + (lambda (url-data) + `((size . ,(assoc-ref url-data "size")) + (compression . ,(assoc-ref url-data "compression")) + (url . ,(assoc-ref url-data "url")))) + urls))) + (signatures + . ,(list->vector + (map + (lambda (signature) + `((version . ,(assoc-ref signature "version")) + (host-name . ,(assoc-ref signature "host_name")))) + signatures)))))) + nars))) + (derivations + . ,(list->vector + (map + (match-lambda + ((filename output-id) + `((filename . ,filename) + (derivations-using-store-item + . ,(list->vector + (map car + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivations-using-output + conn output-id)))))))))) + derivations)))))))))) (define handle-static-assets (if assets-dir-in-store? @@ -393,50 +492,12 @@ mime-types body secret-key-base) (define (controller-thunk) - (match method-and-path-components - (('GET "assets" rest ...) - (or (handle-static-assets (string-join rest "/") - (request-headers request)) - (not-found (request-uri request)))) - (('GET "healthcheck") - (let ((database-status - (catch - #t - (lambda () - (with-postgresql-connection - "web healthcheck" - (lambda (conn) - (number? (count-guix-revisions conn))))) - (lambda (key . args) - #f)))) - (render-json - `((status . ,(if database-status - "ok" - "not ok"))) - #:code (if (eq? database-status - #t) - 200 - 500)))) - (('GET "README") - (let ((filename (string-append (%config '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)))) - (_ - (with-thread-postgresql-connection - (lambda (conn) - (controller-with-database-connection request - method-and-path-components - mime-types - body - conn - secret-key-base)))))) + (actual-controller request + method-and-path-components + mime-types + body + secret-key-base)) + (call-with-error-handling controller-thunk #:on-error 'backtrace @@ -447,12 +508,11 @@ #f)) #:code 500)))) -(define (controller-with-database-connection request - method-and-path-components - mime-types - body - conn - secret-key-base) +(define (actual-controller request + method-and-path-components + mime-types + body + secret-key-base) (define path (uri-path (request-uri request))) @@ -460,8 +520,7 @@ (or (f request method-and-path-components mime-types - body - conn) + body) (render-html #:sxml (general-not-found "Page not found" @@ -473,7 +532,6 @@ method-and-path-components mime-types body - conn secret-key-base) (render-html #:sxml (general-not-found @@ -485,21 +543,63 @@ (('GET) (render-html #:sxml (index - (map - (lambda (git-repository-details) - (cons - git-repository-details - (all-branches-with-most-recent-commit - conn (first git-repository-details)))) - (all-git-repositories conn))))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (map + (lambda (git-repository-details) + (cons + git-repository-details + (all-branches-with-most-recent-commit + conn (first git-repository-details)))) + (all-git-repositories conn)))))))) + (('GET "assets" rest ...) + (or (handle-static-assets (string-join rest "/") + (request-headers request)) + (not-found (request-uri request)))) + (('GET "healthcheck") + (let ((database-status + (catch + #t + (lambda () + (with-postgresql-connection + "web healthcheck" + (lambda (conn) + (number? (count-guix-revisions conn))))) + (lambda (key . args) + #f)))) + (render-json + `((status . ,(if database-status + "ok" + "not ok"))) + #:code (if (eq? database-status + #t) + 200 + 500)))) + (('GET "README") + (let ((filename (string-append (%config '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 "builds") (delegate-to build-controller)) (('GET "statistics") - (render-html - #:sxml (view-statistics (count-guix-revisions conn) - (count-derivations conn)))) + (letpar& ((guix-revisions-count + (with-thread-postgresql-connection count-guix-revisions)) + (count-derivations + (with-thread-postgresql-connection count-derivations))) + + (render-html + #:sxml (view-statistics guix-revisions-count + count-derivations)))) (('GET "metrics") - (render-metrics conn)) + (render-metrics)) (('GET "revision" args ...) (delegate-to revision-controller)) (('GET "repositories") @@ -511,12 +611,11 @@ ;; content negotiation, so just use the path from the request (let ((path (uri-path (request-uri request)))) (if (string-suffix? ".drv" path) - (render-derivation conn path) - (render-store-item conn path)))) + (render-derivation path) + (render-store-item path)))) (('GET "gnu" "store" filename "formatted") (if (string-suffix? ".drv" filename) - (render-formatted-derivation conn - (string-append "/gnu/store/" filename)) + (render-formatted-derivation (string-append "/gnu/store/" filename)) (render-html #:sxml (general-not-found "Not a derivation" @@ -525,20 +624,22 @@ (('GET "gnu" "store" filename "plain") (if (string-suffix? ".drv" filename) (let ((raw-drv - (select-serialized-derivation-by-file-name - conn - (string-append "/gnu/store/" filename)))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-serialized-derivation-by-file-name + conn + (string-append "/gnu/store/" filename))))))) (if raw-drv (render-text raw-drv) (not-found (request-uri request)))) (not-found (request-uri request)))) (('GET "gnu" "store" filename "narinfos") - (render-narinfos conn filename)) + (render-narinfos filename)) (('GET "gnu" "store" filename "json") (if (string-suffix? ".drv" filename) - (render-json-derivation conn - (string-append "/gnu/store/" filename)) - (render-json-store-item conn (string-append "/gnu/store/" filename)))) + (render-json-derivation (string-append "/gnu/store/" filename)) + (render-json-store-item (string-append "/gnu/store/" filename)))) (('GET "build-servers") (delegate-to-with-secret-key-base build-server-controller)) (('GET "dumps" _ ...) diff --git a/guix-data-service/web/dumps/controller.scm b/guix-data-service/web/dumps/controller.scm index 70b6fe9..ecae2d8 100644 --- a/guix-data-service/web/dumps/controller.scm +++ b/guix-data-service/web/dumps/controller.scm @@ -31,8 +31,7 @@ (define (dumps-controller request method-and-path-components mime-types - body - conn) + body) (match method-and-path-components (('GET "dumps") (render-dumps request diff --git a/guix-data-service/web/jobs/controller.scm b/guix-data-service/web/jobs/controller.scm index 3de9827..47034ee 100644 --- a/guix-data-service/web/jobs/controller.scm +++ b/guix-data-service/web/jobs/controller.scm @@ -17,6 +17,8 @@ (define-module (guix-data-service web jobs controller) #:use-module (ice-9 match) + #:use-module (guix-data-service utils) + #:use-module (guix-data-service database) #:use-module (guix-data-service web render) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) @@ -27,8 +29,7 @@ (define (jobs-controller request method-and-path-components mime-types - body - conn) + body) (match method-and-path-components (('GET "jobs") (let ((parsed-query-parameters @@ -42,7 +43,6 @@ (all_results ,parse-checkbox-value))) '((limit_results all_results))))) (render-jobs mime-types - conn parsed-query-parameters))) (('GET "jobs" "events") (let ((parsed-query-parameters @@ -55,11 +55,9 @@ (all_results ,parse-checkbox-value))) '((limit_results all_results))))) (render-job-events mime-types - conn parsed-query-parameters))) (('GET "jobs" "queue") - (render-job-queue mime-types - conn)) + (render-job-queue mime-types)) (('GET "job" job-id) (let ((parsed-query-parameters (parse-query-parameters @@ -67,19 +65,23 @@ `((start_character ,parse-number) (characters ,parse-number #:default 10000000))))) (render-job mime-types - conn job-id parsed-query-parameters))) (_ #f))) -(define (render-jobs mime-types conn query-parameters) - (let* ((limit-results - (assq-ref query-parameters 'limit_results)) - (jobs (select-jobs-and-events - conn - (assq-ref query-parameters 'before_id) - limit-results)) - (recent-events (select-recent-job-events conn))) +(define (render-jobs mime-types query-parameters) + (define limit-results (assq-ref query-parameters 'limit_results)) + + (letpar& ((jobs + (with-thread-postgresql-connection + (lambda (conn) + (select-jobs-and-events + conn + (assq-ref query-parameters 'before_id) + limit-results)))) + (recent-events + (with-thread-postgresql-connection + select-recent-job-events))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -113,29 +115,36 @@ (>= (length jobs) limit-results)))))))) -(define (render-job-events mime-types conn query-parameters) - (let* ((limit-results - (assq-ref query-parameters 'limit_results)) - (recent-events (select-recent-job-events - conn - ;; TODO Ideally there wouldn't be a limit - #:limit (or limit-results 1000000)))) +(define (render-job-events mime-types query-parameters) + (letpar& ((recent-events + (with-thread-postgresql-connection + (lambda (conn) + (select-recent-job-events + conn + ;; TODO Ideally there wouldn't be a limit + #:limit (or (assq-ref query-parameters 'limit_results) + 1000000)))))) (render-html #:sxml (view-job-events query-parameters recent-events)))) -(define (render-job-queue mime-types conn) +(define (render-job-queue mime-types) (render-html #:sxml (view-job-queue - (select-unprocessed-jobs-and-events conn)))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + select-unprocessed-jobs-and-events))))) -(define (render-job mime-types conn job-id query-parameters) - (let ((log-text (log-for-job conn job-id - #:character-limit - (assq-ref query-parameters 'characters) - #:start-character - (assq-ref query-parameters 'start_character)))) +(define (render-job mime-types job-id query-parameters) + (letpar& ((log-text + (with-thread-postgresql-connection + (lambda (conn) + (log-for-job conn job-id + #:character-limit + (assq-ref query-parameters 'characters) + #:start-character + (assq-ref query-parameters 'start_character)))))) (case (most-appropriate-mime-type '(text/plain text/html) mime-types) diff --git a/guix-data-service/web/nar/controller.scm b/guix-data-service/web/nar/controller.scm index 2bf61be..ba8b890 100644 --- a/guix-data-service/web/nar/controller.scm +++ b/guix-data-service/web/nar/controller.scm @@ -31,6 +31,8 @@ #:use-module (guix base32) #:use-module (guix base64) #:use-module (guix serialization) + #:use-module (guix-data-service utils) + #:use-module (guix-data-service database) #:use-module (guix-data-service web render) #:use-module (guix-data-service web nar html) #:use-module (guix-data-service model derivation) @@ -54,8 +56,7 @@ (define (nar-controller request method-and-path-components mime-types - body - conn) + body) (define (.narinfo-suffix s) (string-suffix? ".narinfo" s)) @@ -78,7 +79,6 @@ (uri-decode (last (string-split path #\/))))) (render-nar request mime-types - conn (string-append "/gnu/store/" file-name)))) (('GET "nar" "lzip" _) ;; These routes are a little special, as the extensions aren't used for @@ -88,22 +88,22 @@ (uri-decode (last (string-split path #\/))))) (render-lzip-nar request mime-types - conn (string-append "/gnu/store/" file-name)))) (('GET (? .narinfo-suffix path)) (render-narinfo request - conn (string-drop-right path (string-length ".narinfo")))) (_ #f))) (define (render-nar request mime-types - conn file-name) (or - (and=> (select-serialized-derivation-by-file-name conn - file-name) + (and=> (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-serialized-derivation-by-file-name conn + file-name)))) (lambda (derivation-text) (let ((derivation-bytevector (string->bytevector derivation-text @@ -127,10 +127,13 @@ (define (render-lzip-nar request mime-types - conn file-name) (or - (and=> (select-derivation-source-file-nar-data-by-file-name conn file-name) + (and=> (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-source-file-nar-data-by-file-name conn + file-name)))) (lambda (data) (list (build-response #:code 200 @@ -141,51 +144,60 @@ (not-found (request-uri request)))) (define (render-narinfo request - conn hash) (or - (and=> (select-derivation-by-file-name-hash conn - hash) + (and=> (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-by-file-name-hash conn + hash)))) (lambda (derivation) (list (build-response #:code 200 #:headers '((content-type . (application/x-narinfo)))) - (let* ((derivation-file-name - (second derivation)) - (derivation-text - (select-serialized-derivation-by-file-name - conn - derivation-file-name)) - (derivation-bytevector - (string->bytevector derivation-text - "ISO-8859-1")) + (let ((derivation-file-name (second derivation))) + (letpar& + ((derivation-text + (with-thread-postgresql-connection + (lambda (conn) + (select-serialized-derivation-by-file-name + conn + derivation-file-name)))) (derivation-references - (select-derivation-references-by-derivation-id - conn - (first derivation))) - (nar-bytevector - (call-with-values - (lambda () - (open-bytevector-output-port)) - (lambda (port get-bytevector) - (write-file-tree - derivation-file-name - port - #:file-type+size - (lambda (file) - (values 'regular - (bytevector-length derivation-bytevector))) - #:file-port - (lambda (file) - (open-bytevector-input-port derivation-bytevector))) - (get-bytevector))))) - (lambda (port) - (display (narinfo-string derivation-file-name - nar-bytevector - derivation-references) - port)))))) - (and=> (select-derivation-source-file-data-by-file-name-hash conn - hash) + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-references-by-derivation-id + conn + (first derivation)))))) + (let* ((derivation-bytevector + (string->bytevector derivation-text + "ISO-8859-1")) + (nar-bytevector + (call-with-values + (lambda () + (open-bytevector-output-port)) + (lambda (port get-bytevector) + (write-file-tree + derivation-file-name + port + #:file-type+size + (lambda (file) + (values 'regular + (bytevector-length derivation-bytevector))) + #:file-port + (lambda (file) + (open-bytevector-input-port derivation-bytevector))) + (get-bytevector))))) + (lambda (port) + (display (narinfo-string derivation-file-name + nar-bytevector + derivation-references) + port)))))))) + (and=> (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-source-file-data-by-file-name-hash conn + hash)))) (match-lambda ((store-path compression compressed-size hash-algorithm hash uncompressed-size) diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm index d3c6ab5..84568a9 100644 --- a/guix-data-service/web/repository/controller.scm +++ b/guix-data-service/web/repository/controller.scm @@ -19,6 +19,8 @@ #:use-module (ice-9 match) #:use-module (web uri) #:use-module (web request) + #:use-module (guix-data-service utils) + #:use-module (guix-data-service database) #:use-module (guix-data-service web render) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) @@ -36,14 +38,15 @@ (define (repository-controller request method-and-path-components mime-types - body - conn) + body) (define path (uri-path (request-uri request))) (match method-and-path-components (('GET "repositories") - (let ((git-repositories (all-git-repositories conn))) + (letpar& ((git-repositories + (with-thread-postgresql-connection + all-git-repositories))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -62,11 +65,17 @@ #:sxml (view-git-repositories git-repositories)))))) (('GET "repository" id) - (match (select-git-repository conn id) + (match (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (select-git-repository conn id)))) ((label url cgit-url-base) - (let ((branches - (all-branches-with-most-recent-commit conn - (string->number id)))) + (letpar& ((branches + (with-thread-postgresql-connection + (lambda (conn) + (all-branches-with-most-recent-commit + conn + (string->number id)))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -110,16 +119,18 @@ `((after_date ,parse-datetime) (before_date ,parse-datetime) (limit_results ,parse-result-limit #:default 100))))) - (let ((revisions - (most-recent-commits-for-branch - conn - (string->number repository-id) - branch-name - #:limit (assq-ref parsed-query-parameters 'limit_results) - #:after-date (assq-ref parsed-query-parameters - 'after_date) - #:before-date (assq-ref parsed-query-parameters - 'before_date)))) + (letpar& ((revisions + (with-thread-postgresql-connection + (lambda (conn) + (most-recent-commits-for-branch + conn + (string->number repository-id) + branch-name + #:limit (assq-ref parsed-query-parameters 'limit_results) + #:after-date (assq-ref parsed-query-parameters + 'after_date) + #:before-date (assq-ref parsed-query-parameters + 'before_date)))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -144,11 +155,13 @@ parsed-query-parameters revisions)))))))) (('GET "repository" repository-id "branch" branch-name "package" package-name) - (let ((package-versions - (package-versions-for-branch conn - (string->number repository-id) - branch-name - package-name))) + (letpar& ((package-versions + (with-thread-postgresql-connection + (lambda (conn) + (package-versions-for-branch conn + (string->number repository-id) + branch-name + package-name))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -178,7 +191,6 @@ (('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history") (render-branch-package-derivation-history request mime-types - conn repository-id branch-name package-name)) @@ -186,27 +198,32 @@ "package" package-name "output-history") (render-branch-package-output-history request mime-types - conn repository-id branch-name package-name)) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision") - (let ((commit-hash - (latest-processed-commit-for-branch conn repository-id branch-name))) + (letpar& ((commit-hash + (with-thread-postgresql-connection + (lambda (conn) + (latest-processed-commit-for-branch conn + repository-id + branch-name))))) (if commit-hash (render-view-revision mime-types - conn commit-hash #:path-base path #:header-text `("Latest processed revision for branch " (samp ,branch-name))) (render-unknown-revision mime-types - conn commit-hash)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages") - (let ((commit-hash - (latest-processed-commit-for-branch conn repository-id branch-name))) + (letpar& ((commit-hash + (with-thread-postgresql-connection + (lambda (conn) + (latest-processed-commit-for-branch conn + repository-id + branch-name))))) (if commit-hash (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters @@ -227,7 +244,6 @@ (limit_results all_results))))) (render-revision-packages mime-types - conn commit-hash parsed-query-parameters #:path-base path @@ -240,11 +256,14 @@ "/branch/" branch-name "/latest-processed-revision"))) (render-unknown-revision mime-types - conn commit-hash)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations") - (let ((commit-hash - (latest-processed-commit-for-branch conn repository-id branch-name))) + (letpar& ((commit-hash + (with-thread-postgresql-connection + (lambda (conn) + (latest-processed-commit-for-branch conn + repository-id + branch-name))))) (if commit-hash (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters @@ -265,39 +284,45 @@ '((limit_results all_results))))) (render-revision-package-derivations mime-types - conn commit-hash parsed-query-parameters #:path-base path)) (render-unknown-revision mime-types - conn commit-hash)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility") - (let ((commit-hash - (latest-processed-commit-for-branch conn repository-id branch-name))) + (letpar& ((commit-hash + (with-thread-postgresql-connection + (lambda (conn) + (latest-processed-commit-for-branch conn + repository-id + branch-name))))) (if commit-hash (render-revision-package-reproduciblity mime-types - conn commit-hash #:path-base path) (render-unknown-revision mime-types - conn commit-hash)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability") - (let ((commit-hash - (latest-processed-commit-for-branch conn repository-id branch-name))) + (letpar& ((commit-hash + (with-thread-postgresql-connection + (lambda (conn) + (latest-processed-commit-for-branch conn + repository-id + branch-name))))) (if commit-hash (render-revision-package-substitute-availability mime-types - conn commit-hash #:path-base path) (render-unknown-revision mime-types - conn commit-hash)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "lint-warnings") - (let ((commit-hash - (latest-processed-commit-for-branch conn repository-id branch-name))) + (letpar& ((commit-hash + (with-thread-postgresql-connection + (lambda (conn) + (latest-processed-commit-for-branch conn + repository-id + branch-name))))) (if commit-hash (let ((parsed-query-parameters (parse-query-parameters @@ -312,7 +337,6 @@ "location")))))) (render-revision-lint-warnings mime-types - conn commit-hash parsed-query-parameters #:path-base path @@ -325,43 +349,46 @@ "/branch/" branch-name "/latest-processed-revision"))) (render-unknown-revision mime-types - conn commit-hash)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version) - (let ((commit-hash - (latest-processed-commit-for-branch conn repository-id branch-name)) - (parsed-query-parameters - (parse-query-parameters - request - `((locale ,identity #:default "en_US.UTF-8"))))) - (if commit-hash - (render-revision-package-version mime-types - conn - commit-hash - name - version - parsed-query-parameters - #:header-text - `("Latest processed revision for branch " - (samp ,branch-name)) - #:header-link - (string-append - "/repository/" repository-id - "/branch/" branch-name - "/latest-processed-revision") - #:version-history-link - (string-append - "/repository/" repository-id - "/branch/" branch-name - "/package/" name)) - (render-unknown-revision mime-types - conn - commit-hash)))) - (_ #f))) + (letpar& ((commit-hash + (with-thread-postgresql-connection + (lambda (conn) + (latest-processed-commit-for-branch conn + repository-id + branch-name))))) + (let ((parsed-query-parameters + (parse-query-parameters + request + `((locale ,identity #:default "en_US.UTF-8"))))) + (if commit-hash + (render-revision-package-version mime-types + commit-hash + name + version + parsed-query-parameters + #:header-text + `("Latest processed revision for branch " + (samp ,branch-name)) + #:header-link + (string-append + "/repository/" repository-id + "/branch/" branch-name + "/latest-processed-revision") + #:version-history-link + (string-append + "/repository/" repository-id + "/branch/" branch-name + "/package/" name)) + (render-unknown-revision mime-types + commit-hash))))) + (_ #f))) -(define (parse-build-system conn) +(define (parse-build-system) (let ((systems - (valid-systems conn))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + valid-systems)))) (lambda (s) (if (member s systems) s @@ -370,70 +397,77 @@ (define (render-branch-package-derivation-history request mime-types - conn repository-id branch-name package-name) (let ((parsed-query-parameters (parse-query-parameters request - `((system ,(parse-build-system conn) + `((system ,(parse-build-system) #:default "x86_64-linux") (target ,parse-target #:default ""))))) - (let* ((system - (assq-ref parsed-query-parameters 'system)) - (target - (assq-ref parsed-query-parameters 'target)) - (package-derivations - (package-derivations-for-branch conn - (string->number repository-id) - branch-name - system - target - package-name)) + (let ((system + (assq-ref parsed-query-parameters 'system)) + (target + (assq-ref parsed-query-parameters 'target))) + (letpar& + ((package-derivations + (with-thread-postgresql-connection + (lambda (conn) + (package-derivations-for-branch conn + (string->number repository-id) + branch-name + system + target + package-name)))) (build-server-urls - (select-build-server-urls-by-id conn))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((derivations . ,(list->vector - (map (match-lambda - ((package-version derivation-file-name - first-guix-revision-commit - first-datetime - last-guix-revision-commit - last-datetime - builds) - `((version . ,package-version) - (derivation . ,derivation-file-name) - (first_revision - . ((commit . ,first-guix-revision-commit) - (datetime . ,first-datetime))) - (last_revision - . ((commit . ,last-guix-revision-commit) - (datetime . ,last-datetime))) - (builds - . ,(list->vector builds))))) - package-derivations)))))) - (else - (render-html - #:sxml (view-branch-package-derivations - parsed-query-parameters - repository-id - branch-name - package-name - (valid-systems conn) - (valid-targets->options - (valid-targets conn)) - build-server-urls - package-derivations))))))) + (with-thread-postgresql-connection + select-build-server-urls-by-id))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((derivations . ,(list->vector + (map (match-lambda + ((package-version derivation-file-name + first-guix-revision-commit + first-datetime + last-guix-revision-commit + last-datetime + builds) + `((version . ,package-version) + (derivation . ,derivation-file-name) + (first_revision + . ((commit . ,first-guix-revision-commit) + (datetime . ,first-datetime))) + (last_revision + . ((commit . ,last-guix-revision-commit) + (datetime . ,last-datetime))) + (builds + . ,(list->vector builds))))) + package-derivations)))))) + (else + (letpar& ((systems + (with-thread-postgresql-connection + valid-systems)) + (targets + (with-thread-postgresql-connection + valid-targets))) + (render-html + #:sxml (view-branch-package-derivations + parsed-query-parameters + repository-id + branch-name + package-name + systems + (valid-targets->options targets) + build-server-urls + package-derivations))))))))) (define (render-branch-package-output-history request mime-types - conn repository-id branch-name package-name) @@ -442,60 +476,69 @@ request `((output ,identity #:default "out") - (system ,(parse-build-system conn) + (system ,(parse-build-system) #:default "x86_64-linux") (target ,parse-target #:default ""))))) - (let* ((system - (assq-ref parsed-query-parameters 'system)) - (target - (assq-ref parsed-query-parameters 'target)) - (output-name - (assq-ref parsed-query-parameters 'output)) - (package-outputs - (package-outputs-for-branch conn - (string->number repository-id) - branch-name - system - target - package-name - output-name)) + (let ((system + (assq-ref parsed-query-parameters 'system)) + (target + (assq-ref parsed-query-parameters 'target)) + (output-name + (assq-ref parsed-query-parameters 'output))) + (letpar& + ((package-outputs + (with-thread-postgresql-connection + (lambda (conn) + (package-outputs-for-branch conn + (string->number repository-id) + branch-name + system + target + package-name + output-name)))) (build-server-urls - (select-build-server-urls-by-id conn))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((derivations . ,(list->vector - (map (match-lambda - ((package-version derivation-file-name - first-guix-revision-commit - first-datetime - last-guix-revision-commit - last-datetime - builds) - `((version . ,package-version) - (derivation . ,derivation-file-name) - (first_revision - . ((commit . ,first-guix-revision-commit) - (datetime . ,first-datetime))) - (last_revision - . ((commit . ,last-guix-revision-commit) - (datetime . ,last-datetime))) - (builds - . ,(list->vector builds))))) - package-outputs)))))) - (else - (render-html - #:sxml (view-branch-package-outputs - parsed-query-parameters - repository-id - branch-name - package-name - output-name - (valid-systems conn) - (valid-targets->options - (valid-targets conn)) - build-server-urls - package-outputs))))))) + (with-thread-postgresql-connection + select-build-server-urls-by-id))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((derivations . ,(list->vector + (map (match-lambda + ((package-version derivation-file-name + first-guix-revision-commit + first-datetime + last-guix-revision-commit + last-datetime + builds) + `((version . ,package-version) + (derivation . ,derivation-file-name) + (first_revision + . ((commit . ,first-guix-revision-commit) + (datetime . ,first-datetime))) + (last_revision + . ((commit . ,last-guix-revision-commit) + (datetime . ,last-datetime))) + (builds + . ,(list->vector builds))))) + package-outputs)))))) + (else + (letpar& ((systems + (with-thread-postgresql-connection + valid-systems)) + (targets + (with-thread-postgresql-connection + valid-targets))) + (render-html + #:sxml (view-branch-package-outputs + parsed-query-parameters + repository-id + branch-name + package-name + output-name + systems + (valid-targets->options targets) + build-server-urls + package-outputs))))))))) diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index be6a4d0..d5049e0 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -24,6 +24,8 @@ #:use-module (texinfo html) #:use-module (texinfo plain-text) #:use-module (json) + #:use-module (guix-data-service utils) + #:use-module (guix-data-service database) #:use-module (guix-data-service web render) #:use-module (guix-data-service web sxml) #:use-module (guix-data-service web query-parameters) @@ -75,52 +77,57 @@ (string-append "unknown build status: " status)))) -(define (parse-build-server conn) - (lambda (v) - (let ((build-servers (select-build-servers conn))) - (or (any (match-lambda - ((id url lookup-all-derivations? lookup-builds?) - (if (eq? (string->number v) - id) - id - #f))) - build-servers) - (make-invalid-query-parameter - v - "unknown build server"))))) +(define (parse-build-server v) + (letpar& ((build-servers + (with-thread-postgresql-connection select-build-servers))) + (or (any (match-lambda + ((id url lookup-all-derivations? lookup-builds?) + (if (eq? (string->number v) + id) + id + #f))) + build-servers) + (make-invalid-query-parameter + v + "unknown build server")))) (define (revision-controller request method-and-path-components mime-types - body - conn) + body) (define path (uri-path (request-uri request))) (match method-and-path-components - (('GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash) - (render-view-revision mime-types - conn - commit-hash - #:path-base path) - (render-unknown-revision mime-types - conn - commit-hash))) + (('GET "revision" commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) + (render-view-revision mime-types + commit-hash + #:path-base path) + (render-unknown-revision mime-types + commit-hash))) (('GET "revision" commit-hash "news") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (let ((parsed-query-parameters (parse-query-parameters request `((lang ,identity #:multi-value))))) (render-revision-news mime-types - conn commit-hash parsed-query-parameters)) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "packages") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters @@ -140,48 +147,52 @@ (limit_results all_results))))) (render-revision-packages mime-types - conn commit-hash parsed-query-parameters #:path-base path)) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "packages-translation-availability") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (render-revision-packages-translation-availability mime-types - conn commit-hash #:path-base path) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "package" name) - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (render-revision-package mime-types - conn commit-hash name) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "package" name version) - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (let ((parsed-query-parameters (parse-query-parameters request `((locale ,identity #:default "en_US.UTF-8"))))) (render-revision-package-version mime-types - conn commit-hash name version parsed-query-parameters)) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "package-derivations") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters @@ -201,15 +212,16 @@ '((limit_results all_results))))) (render-revision-package-derivations mime-types - conn commit-hash parsed-query-parameters #:path-base path)) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "package-derivation-outputs") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters @@ -231,62 +243,67 @@ '((limit_results all_results))))) (render-revision-package-derivation-outputs mime-types - conn commit-hash parsed-query-parameters #:path-base path)) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "system-tests") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (let ((parsed-query-parameters (parse-query-parameters request `((system ,parse-system #:default "x86_64-linux"))))) (render-revision-system-tests mime-types - conn commit-hash parsed-query-parameters #:path-base path)) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "channel-instances") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (render-revision-channel-instances mime-types - conn commit-hash #:path-base path) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "package-substitute-availability") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (render-revision-package-substitute-availability mime-types - conn commit-hash #:path-base path) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "package-reproducibility") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (render-revision-package-reproduciblity mime-types - conn commit-hash #:path-base path) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "builds") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters request `((build_status ,parse-build-status #:multi-value) - (build_server ,(parse-build-server conn) #:multi-value) + (build_server ,parse-build-server #:multi-value) (system ,parse-system #:default "x86_64-linux") (target ,parse-target #:default "") (limit_results ,parse-result-limit @@ -296,15 +313,16 @@ '((limit_results all_results))))) (render-revision-builds mime-types - conn commit-hash parsed-query-parameters #:path-base path)) (render-unknown-revision mime-types - conn commit-hash))) (('GET "revision" commit-hash "lint-warnings") - (if (guix-commit-exists? conn commit-hash) + (if (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (guix-commit-exists? conn commit-hash)))) (let ((parsed-query-parameters (parse-query-parameters request @@ -318,12 +336,10 @@ "location")))))) (render-revision-lint-warnings mime-types - conn commit-hash parsed-query-parameters #:path-base path)) (render-unknown-revision mime-types - conn commit-hash))) (_ #f))) @@ -336,7 +352,7 @@ (plain . ,(stexi->plain-text stexi)) (locale . ,locale)))) -(define (render-unknown-revision mime-types conn commit-hash) +(define (render-unknown-revision mime-types commit-hash) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -345,31 +361,55 @@ '((unknown_commit . ,commit-hash)) #:code 404)) (else + (letpar& ((job + (with-thread-postgresql-connection + (lambda (conn) + (select-job-for-commit conn commit-hash)))) + (git-repositories-and-branches + (with-thread-postgresql-connection + (lambda (conn) + (git-branches-with-repository-details-for-commit conn + commit-hash)))) + (jobs-and-events + (with-thread-postgresql-connection + (lambda (conn) + (select-jobs-and-events-for-commit conn commit-hash))))) + (render-html #:code 404 #:sxml (unknown-revision commit-hash - (select-job-for-commit - conn commit-hash) - (git-branches-with-repository-details-for-commit conn commit-hash) - (select-jobs-and-events-for-commit conn commit-hash)))))) + job + git-repositories-and-branches + jobs-and-events)))))) (define* (render-view-revision mime-types - conn commit-hash #:key path-base (header-text `("Revision " (samp ,commit-hash)))) - (let ((packages-count - (count-packages-in-revision conn commit-hash)) - (git-repositories-and-branches - (git-branches-with-repository-details-for-commit conn commit-hash)) - (derivations-counts - (count-packages-derivations-in-revision conn commit-hash)) - (jobs-and-events - (select-jobs-and-events-for-commit conn commit-hash)) - (lint-warning-counts - (lint-warning-count-by-lint-checker-for-revision conn commit-hash))) + (letpar& ((packages-count + (with-thread-postgresql-connection + (lambda (conn) + (count-packages-in-revision conn commit-hash)))) + (git-repositories-and-branches + (with-thread-postgresql-connection + (lambda (conn) + (git-branches-with-repository-details-for-commit conn + commit-hash)))) + (derivations-counts + (with-thread-postgresql-connection + (lambda (conn) + (count-packages-derivations-in-revision conn commit-hash)))) + (jobs-and-events + (with-thread-postgresql-connection + (lambda (conn) + (select-jobs-and-events-for-commit conn commit-hash)))) + (lint-warning-counts + (with-thread-postgresql-connection + (lambda (conn) + (lint-warning-count-by-lint-checker-for-revision conn + commit-hash))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -404,7 +444,6 @@ #:extra-headers http-headers-for-unchanging-content))))) (define* (render-revision-system-tests mime-types - conn commit-hash query-parameters #:key @@ -413,11 +452,13 @@ `("Revision " (samp ,commit-hash))) (header-link (string-append "/revision/" commit-hash))) - (let ((system-tests - (select-system-tests-for-guix-revision - conn - (assq-ref query-parameters 'system) - commit-hash))) + (letpar& ((system-tests + (with-thread-postgresql-connection + (lambda (conn) + (select-system-tests-for-guix-revision + conn + (assq-ref query-parameters 'system) + commit-hash))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -440,20 +481,25 @@ (builds . ,(list->vector builds))))) system-tests)))))) (else - (render-html - #:sxml (view-revision-system-tests - commit-hash - system-tests - (git-repositories-containing-commit conn - commit-hash) - (valid-systems conn) - query-parameters - #:path-base path-base - #:header-text header-text - #:header-link header-link)))))) + (letpar& ((git-repositories + (with-thread-postgresql-connection + (lambda (conn) + (git-repositories-containing-commit conn + commit-hash)))) + (systems + (with-thread-postgresql-connection valid-systems))) + (render-html + #:sxml (view-revision-system-tests + commit-hash + system-tests + git-repositories + systems + query-parameters + #:path-base path-base + #:header-text header-text + #:header-link header-link))))))) (define* (render-revision-channel-instances mime-types - conn commit-hash #:key (path-base "/revision/") @@ -462,8 +508,10 @@ (header-link (string-append "/revision/" commit-hash))) - (let ((channel-instances - (select-channel-instances-for-guix-revision conn commit-hash))) + (letpar& ((channel-instances + (with-thread-postgresql-connection + (lambda (conn) + (select-channel-instances-for-guix-revision conn commit-hash))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -487,13 +535,16 @@ #:header-link header-link)))))) (define* (render-revision-package-substitute-availability mime-types - conn commit-hash #:key path-base) - (let ((substitute-availability - (select-package-output-availability-for-revision conn commit-hash)) - (build-server-urls - (select-build-server-urls-by-id conn))) + (letpar& ((substitute-availability + (with-thread-postgresql-connection + (lambda (conn) + (select-package-output-availability-for-revision conn + commit-hash)))) + (build-server-urls + (with-thread-postgresql-connection + select-build-server-urls-by-id))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -508,11 +559,12 @@ build-server-urls)))))) (define* (render-revision-package-reproduciblity mime-types - conn commit-hash #:key path-base) - (let ((output-consistency - (select-output-consistency-for-revision conn commit-hash))) + (letpar& ((output-consistency + (with-thread-postgresql-connection + (lambda (conn) + (select-output-consistency-for-revision conn commit-hash))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -526,7 +578,6 @@ output-consistency)))))) (define (render-revision-news mime-types - conn commit-hash query-parameters) (if (any-invalid-query-parameters? query-parameters) @@ -541,9 +592,12 @@ #:sxml (view-revision-news commit-hash query-parameters '())))) - (let ((news-entries - (select-channel-news-entries-contained-in-guix-revision conn - commit-hash))) + (letpar& ((news-entries + (with-thread-postgresql-connection + (lambda (conn) + (select-channel-news-entries-contained-in-guix-revision + conn + commit-hash))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -558,7 +612,6 @@ #:extra-headers http-headers-for-unchanging-content)))))) (define* (render-revision-packages mime-types - conn commit-hash query-parameters #:key @@ -589,101 +642,109 @@ '() #f #f + #f #:path-base path-base #:header-text header-text #:header-link header-link)))) - (let* ((search-query (assq-ref query-parameters 'search_query)) - (limit-results (or (assq-ref query-parameters 'limit_results) - 99999)) ; TODO There shouldn't be a limit - (fields (assq-ref query-parameters 'field)) - (locale (assq-ref query-parameters 'locale)) - (packages - (if search-query - (search-packages-in-revision - conn - commit-hash - search-query - #:limit-results limit-results - #:locale locale) - (select-packages-in-revision - conn - commit-hash - #:limit-results limit-results - #:after-name (assq-ref query-parameters 'after_name) - #:locale (assq-ref query-parameters 'locale)))) + (let ((search-query (assq-ref query-parameters 'search_query)) + (limit-results (or (assq-ref query-parameters 'limit_results) + 99999)) ; TODO There shouldn't be a limit + (fields (assq-ref query-parameters 'field)) + (locale (assq-ref query-parameters 'locale))) + (letpar& + ((packages + (with-thread-postgresql-connection + (lambda (conn) + (if search-query + (search-packages-in-revision + conn + commit-hash + search-query + #:limit-results limit-results + #:locale locale) + (select-packages-in-revision + conn + commit-hash + #:limit-results limit-results + #:after-name (assq-ref query-parameters 'after_name) + #:locale (assq-ref query-parameters 'locale)))))) (git-repositories - (git-repositories-containing-commit conn - commit-hash)) - (show-next-page? - (and (not search-query) - (>= (length packages) - limit-results))) - (any-translations? (any-package-synopsis-or-descriptions-translations? - packages locale))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((revision - . ((commit . ,commit-hash))) - (packages - . ,(list->vector - (map (match-lambda - ((name version synopsis synopsis-locale description description-locale home-page - location-file location-line - location-column-number licenses) - `((name . ,name) - ,@(if (member "version" fields) - `((version . ,version)) - '()) - ,@(if (member "synopsis" fields) - `((synopsis - . ,(texinfo->variants-alist synopsis synopsis-locale))) - '()) - ,@(if (member "description" fields) - `((description - . ,(texinfo->variants-alist description description-locale))) - '()) - ,@(if (member "home-page" fields) - `((home-page . ,home-page)) - '()) - ,@(if (member "location" fields) - `((location - . ((file . ,location-file) - (line . ,location-line) - (column . ,location-column-number)))) - '()) - ,@(if (member "licenses" fields) - `((licenses - . ,(if (string-null? licenses) - #() - (json-string->scm licenses)))) - '())))) - packages)))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (let ((locale-options - (description-and-synopsis-locale-options - (package-description-and-synopsis-locale-options-guix-revision - conn - (commit->revision-id conn commit-hash))))) - (render-html - #:sxml (view-revision-packages commit-hash - query-parameters - packages - git-repositories - show-next-page? - locale-options - any-translations? - #:path-base path-base - #:header-text header-text - #:header-link header-link) - #:extra-headers http-headers-for-unchanging-content))))))) + (with-thread-postgresql-connection + (lambda (conn) + (git-repositories-containing-commit conn + commit-hash))))) + (let ((show-next-page? + (and (not search-query) + (>= (length packages) + limit-results))) + (any-translations? (any-package-synopsis-or-descriptions-translations? + packages locale))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((revision + . ((commit . ,commit-hash))) + (packages + . ,(list->vector + (map (match-lambda + ((name version synopsis synopsis-locale description description-locale home-page + location-file location-line + location-column-number licenses) + `((name . ,name) + ,@(if (member "version" fields) + `((version . ,version)) + '()) + ,@(if (member "synopsis" fields) + `((synopsis + . ,(texinfo->variants-alist synopsis synopsis-locale))) + '()) + ,@(if (member "description" fields) + `((description + . ,(texinfo->variants-alist description description-locale))) + '()) + ,@(if (member "home-page" fields) + `((home-page . ,home-page)) + '()) + ,@(if (member "location" fields) + `((location + . ((file . ,location-file) + (line . ,location-line) + (column . ,location-column-number)))) + '()) + ,@(if (member "licenses" fields) + `((licenses + . ,(if (string-null? licenses) + #() + (json-string->scm licenses)))) + '())))) + packages)))) + #:extra-headers http-headers-for-unchanging-content)) + (else + (letpar& + ((locale-options + (with-thread-postgresql-connection + (lambda (conn) + (description-and-synopsis-locale-options + (package-description-and-synopsis-locale-options-guix-revision + conn + (commit->revision-id conn commit-hash))))))) + (render-html + #:sxml (view-revision-packages commit-hash + query-parameters + packages + git-repositories + show-next-page? + locale-options + any-translations? + #:path-base path-base + #:header-text header-text + #:header-link header-link) + #:extra-headers http-headers-for-unchanging-content))))))))) (define* (render-revision-packages-translation-availability mime-types - conn commit-hash #:key path-base @@ -692,14 +753,20 @@ "/revision/" commit-hash)) (header-text `("Revision " (samp ,commit-hash)))) - (let ((package-synopsis-counts - (synopsis-counts-by-locale conn - (commit->revision-id conn - commit-hash))) - (package-description-counts - (description-counts-by-locale conn - (commit->revision-id conn - commit-hash)))) + (letpar& ((package-synopsis-counts + (with-thread-postgresql-connection + (lambda (conn) + (synopsis-counts-by-locale conn + (commit->revision-id + conn + commit-hash))))) + (package-description-counts + (with-thread-postgresql-connection + (lambda (conn) + (description-counts-by-locale conn + (commit->revision-id + conn + commit-hash)))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -718,7 +785,6 @@ #:header-text header-text)))))) (define* (render-revision-package mime-types - conn commit-hash name #:key @@ -729,13 +795,17 @@ (header-link (string-append "/revision/" commit-hash))) - (let ((package-versions - (select-package-versions-for-revision conn - commit-hash - name)) - (git-repositories-and-branches - (git-branches-with-repository-details-for-commit conn - commit-hash))) + (letpar& ((package-versions + (with-thread-postgresql-connection + (lambda (conn) + (select-package-versions-for-revision conn + commit-hash + name)))) + (git-repositories-and-branches + (with-thread-postgresql-connection + (lambda (conn) + (git-branches-with-repository-details-for-commit conn + commit-hash))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -755,7 +825,6 @@ #:extra-headers http-headers-for-unchanging-content))))) (define* (render-revision-package-version mime-types - conn commit-hash name version @@ -774,36 +843,48 @@ (match-lambda ((locale) locale)) - (delete-duplicates - (append - (package-description-and-synopsis-locale-options-guix-revision - conn (commit->revision-id conn commit-hash)) - (lint-warning-message-locales-for-revision conn commit-hash))))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (delete-duplicates + (append + (package-description-and-synopsis-locale-options-guix-revision + conn (commit->revision-id conn commit-hash)) + (lint-warning-message-locales-for-revision conn commit-hash)))))))) - (let* ((locale (assq-ref query-parameters 'locale)) - (metadata - (select-package-metadata-by-revision-name-and-version - conn - commit-hash - name - version - locale)) - (derivations - (select-derivations-by-revision-name-and-version - conn - commit-hash - name - version)) - (git-repositories - (git-repositories-containing-commit conn - commit-hash)) - (lint-warnings - (select-lint-warnings-by-revision-package-name-and-version - conn - commit-hash - name - version - #:locale locale))) + (define locale (assq-ref query-parameters 'locale)) + + (letpar& ((metadata + (with-thread-postgresql-connection + (lambda (conn) + (select-package-metadata-by-revision-name-and-version + conn + commit-hash + name + version + locale)))) + (derivations + (with-thread-postgresql-connection + (lambda (conn) + (select-derivations-by-revision-name-and-version + conn + commit-hash + name + version)))) + (git-repositories + (with-thread-postgresql-connection + (lambda (conn) + (git-repositories-containing-commit conn + commit-hash)))) + (lint-warnings + (with-thread-postgresql-connection + (lambda (conn) + (select-lint-warnings-by-revision-package-name-and-version + conn + commit-hash + name + version + #:locale locale))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -843,7 +924,6 @@ #:extra-headers http-headers-for-unchanging-content))))) (define* (render-revision-package-derivations mime-types - conn commit-hash query-parameters #:key @@ -861,100 +941,110 @@ (render-json `((error . "invalid query")))) (else - (render-html - #:sxml (view-revision-package-derivations commit-hash - query-parameters - (valid-systems conn) - (valid-targets->options - (valid-targets conn)) - '() - '() - #f - #:path-base path-base - #:header-text header-text - #:header-link header-link)))) - (let* ((limit-results - (assq-ref query-parameters 'limit_results)) - (all-results - (assq-ref query-parameters 'all_results)) - (search-query - (assq-ref query-parameters 'search_query)) - (fields - (assq-ref query-parameters 'field)) - (derivations - (if search-query - (search-package-derivations-in-revision - conn - commit-hash - search-query - #:systems (assq-ref query-parameters 'system) - #:targets (assq-ref query-parameters 'target) - #:maximum-builds (assq-ref query-parameters 'maximum_builds) - #:minimum-builds (assq-ref query-parameters 'minimum_builds) - #:limit-results limit-results - #:after-name (assq-ref query-parameters 'after_name) - #:include-builds? (member "builds" fields)) - (select-package-derivations-in-revision - conn - commit-hash - #:systems (assq-ref query-parameters 'system) - #:targets (assq-ref query-parameters 'target) - #:maximum-builds (assq-ref query-parameters 'maximum_builds) - #:minimum-builds (assq-ref query-parameters 'minimum_builds) - #:limit-results limit-results - #:after-name (assq-ref query-parameters 'after_name) - #:include-builds? (member "builds" fields)))) - (build-server-urls - (select-build-server-urls-by-id conn)) - (show-next-page? - (if all-results - #f - (and (not (null? derivations)) - (>= (length derivations) - limit-results))))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((derivations . ,(list->vector - (map (match-lambda - ((derivation system target) - `((derivation . ,derivation) - ,@(if (member "system" fields) - `((system . ,system)) - '()) - ,@(if (member "target" fields) - `((target . ,target)) - '()))) - ((derivation system target builds) - `((derivation . ,derivation) - ,@(if (member "system" fields) - `((system . ,system)) - '()) - ,@(if (member "target" fields) - `((target . ,target)) - '()) - (builds . ,builds)))) - derivations)))))) - (else + (letpar& ((systems + (with-thread-postgresql-connection valid-systems)) + (targets + (with-thread-postgresql-connection valid-targets))) (render-html - #:sxml (view-revision-package-derivations - commit-hash - query-parameters - (valid-systems conn) - (valid-targets->options - (valid-targets conn)) - derivations - build-server-urls - show-next-page? - #:path-base path-base - #:header-text header-text - #:header-link header-link))))))) + #:sxml (view-revision-package-derivations commit-hash + query-parameters + systems + (valid-targets->options + targets) + '() + '() + #f + #:path-base path-base + #:header-text header-text + #:header-link header-link))))) + (let ((limit-results + (assq-ref query-parameters 'limit_results)) + (all-results + (assq-ref query-parameters 'all_results)) + (search-query + (assq-ref query-parameters 'search_query)) + (fields + (assq-ref query-parameters 'field))) + (letpar& + ((derivations + (with-thread-postgresql-connection + (lambda (conn) + (if search-query + (search-package-derivations-in-revision + conn + commit-hash + search-query + #:systems (assq-ref query-parameters 'system) + #:targets (assq-ref query-parameters 'target) + #:maximum-builds (assq-ref query-parameters 'maximum_builds) + #:minimum-builds (assq-ref query-parameters 'minimum_builds) + #:limit-results limit-results + #:after-name (assq-ref query-parameters 'after_name) + #:include-builds? (member "builds" fields)) + (select-package-derivations-in-revision + conn + commit-hash + #:systems (assq-ref query-parameters 'system) + #:targets (assq-ref query-parameters 'target) + #:maximum-builds (assq-ref query-parameters 'maximum_builds) + #:minimum-builds (assq-ref query-parameters 'minimum_builds) + #:limit-results limit-results + #:after-name (assq-ref query-parameters 'after_name) + #:include-builds? (member "builds" fields)))))) + (build-server-urls + (with-thread-postgresql-connection + select-build-server-urls-by-id))) + (let ((show-next-page? + (if all-results + #f + (and (not (null? derivations)) + (>= (length derivations) + limit-results))))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((derivations . ,(list->vector + (map (match-lambda + ((derivation system target) + `((derivation . ,derivation) + ,@(if (member "system" fields) + `((system . ,system)) + '()) + ,@(if (member "target" fields) + `((target . ,target)) + '()))) + ((derivation system target builds) + `((derivation . ,derivation) + ,@(if (member "system" fields) + `((system . ,system)) + '()) + ,@(if (member "target" fields) + `((target . ,target)) + '()) + (builds . ,builds)))) + derivations)))))) + (else + (letpar& ((systems + (with-thread-postgresql-connection valid-systems)) + (targets + (with-thread-postgresql-connection valid-targets))) + (render-html + #:sxml (view-revision-package-derivations + commit-hash + query-parameters + systems + (valid-targets->options targets) + derivations + build-server-urls + show-next-page? + #:path-base path-base + #:header-text header-text + #:header-link header-link)))))))))) (define* (render-revision-package-derivation-outputs mime-types - conn commit-hash query-parameters #:key @@ -964,7 +1054,8 @@ (header-link (string-append "/revision/" commit-hash))) (define build-server-urls - (select-build-server-urls-by-id conn)) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection select-build-server-urls-by-id))) (if (any-invalid-query-parameters? query-parameters) (case (most-appropriate-mime-type @@ -974,66 +1065,74 @@ (render-json `((error . "invalid query")))) (else - (render-html - #:sxml (view-revision-package-derivation-outputs - commit-hash - query-parameters - '() - build-server-urls - (valid-systems conn) - (valid-targets->options - (valid-targets conn)) - #f - #:path-base path-base - #:header-text header-text - #:header-link header-link)))) - (let* ((limit-results - (assq-ref query-parameters 'limit_results)) - (all-results - (assq-ref query-parameters 'all_results)) - (derivation-outputs - (select-derivation-outputs-in-revision - conn - commit-hash - #:search-query (assq-ref query-parameters 'search_query) - #:nars-from-build-servers - (assq-ref query-parameters 'substitutes_available_from) - #:no-nars-from-build-servers - (assq-ref query-parameters 'substitutes_not_available_from) - #:output-consistency - (assq-ref query-parameters 'output_consistency) - #:system (assq-ref query-parameters 'system) - #:target (assq-ref query-parameters 'target) - #:limit-results limit-results - #:after-path (assq-ref query-parameters 'after_path))) - (show-next-page? - (if all-results - #f - (>= (length derivation-outputs) - limit-results)))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `())) - (else + (letpar& ((systems + (with-thread-postgresql-connection valid-systems)) + (targets + (with-thread-postgresql-connection valid-targets))) (render-html #:sxml (view-revision-package-derivation-outputs commit-hash query-parameters - derivation-outputs + '() build-server-urls - (valid-systems conn) - (valid-targets->options - (valid-targets conn)) - show-next-page? + systems + (valid-targets->options targets) + #f #:path-base path-base #:header-text header-text - #:header-link header-link))))))) + #:header-link header-link))))) + (let ((limit-results + (assq-ref query-parameters 'limit_results)) + (all-results + (assq-ref query-parameters 'all_results))) + (letpar& + ((derivation-outputs + (with-thread-postgresql-connection + (lambda (conn) + (select-derivation-outputs-in-revision + conn + commit-hash + #:search-query (assq-ref query-parameters 'search_query) + #:nars-from-build-servers + (assq-ref query-parameters 'substitutes_available_from) + #:no-nars-from-build-servers + (assq-ref query-parameters 'substitutes_not_available_from) + #:output-consistency + (assq-ref query-parameters 'output_consistency) + #:system (assq-ref query-parameters 'system) + #:target (assq-ref query-parameters 'target) + #:limit-results limit-results + #:after-path (assq-ref query-parameters 'after_path)))))) + (let ((show-next-page? + (if all-results + #f + (>= (length derivation-outputs) + limit-results)))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `())) + (else + (letpar& ((systems + (with-thread-postgresql-connection valid-systems)) + (targets + (with-thread-postgresql-connection valid-targets))) + (render-html + #:sxml (view-revision-package-derivation-outputs + commit-hash + query-parameters + derivation-outputs + build-server-urls + systems + (valid-targets->options targets) + show-next-page? + #:path-base path-base + #:header-text header-text + #:header-link header-link)))))))))) (define* (render-revision-builds mime-types - conn commit-hash query-parameters #:key @@ -1043,51 +1142,69 @@ (header-link (string-append "/revision/" commit-hash))) (if (any-invalid-query-parameters? query-parameters) - (render-html - #:sxml (view-revision-builds query-parameters - commit-hash - build-status-strings - (valid-systems conn) - (valid-targets->options - (valid-targets conn)) - '() - '() - '())) + (letpar& ((systems + (with-thread-postgresql-connection valid-systems)) + (targets + (with-thread-postgresql-connection valid-targets))) + (render-html + #:sxml + (view-revision-builds query-parameters + commit-hash + build-status-strings + systems + (valid-targets->options targets) + '() + '() + '()))) (let ((system (assq-ref query-parameters 'system)) (target (assq-ref query-parameters 'target))) - (render-html - #:sxml (view-revision-builds query-parameters - commit-hash - build-status-strings - (valid-systems conn) - (valid-targets->options - (valid-targets conn)) - (map (match-lambda - ((id url lookup-all-derivations - lookup-builds) - (cons url id))) - (select-build-servers conn)) - (select-build-stats - conn - (assq-ref query-parameters - 'build_server) - #:revision-commit commit-hash - #:system system - #:target target) - (select-builds-with-context - conn - (assq-ref query-parameters - 'build_status) - (assq-ref query-parameters - 'build_server) - #:revision-commit commit-hash - #:system system - #:target target - #:limit (assq-ref query-parameters - 'limit_results))))))) + (letpar& ((systems + (with-thread-postgresql-connection valid-systems)) + (targets + (with-thread-postgresql-connection valid-targets)) + (build-server-options + (with-thread-postgresql-connection + (lambda (conn) + (map (match-lambda + ((id url lookup-all-derivations + lookup-builds) + (cons url id))) + (select-build-servers conn))))) + (stats + (with-thread-postgresql-connection + (lambda (conn) + (select-build-stats + conn + (assq-ref query-parameters + 'build_server) + #:revision-commit commit-hash + #:system system + #:target target)))) + (builds + (with-thread-postgresql-connection + (lambda (conn) + (select-builds-with-context + conn + (assq-ref query-parameters + 'build_status) + (assq-ref query-parameters + 'build_server) + #:revision-commit commit-hash + #:system system + #:target target + #:limit (assq-ref query-parameters + 'limit_results)))))) + (render-html + #:sxml (view-revision-builds query-parameters + commit-hash + build-status-strings + systems + (valid-targets->options targets) + build-server-options + stats + builds)))))) (define* (render-revision-lint-warnings mime-types - conn commit-hash query-parameters #:key @@ -1097,18 +1214,24 @@ (header-link (string-append "/revision/" commit-hash))) (define lint-checker-options - (map (match-lambda - ((name description network-dependent) - (cons (string-append name ": " description ) - name))) - (lint-checkers-for-revision conn commit-hash))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (map (match-lambda + ((name description network-dependent) + (cons (string-append name ": " description ) + name))) + (lint-checkers-for-revision conn commit-hash)))))) (define lint-warnings-locale-options - (map - (match-lambda - ((locale) - locale)) - (lint-warning-message-locales-for-revision conn commit-hash))) + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (map + (match-lambda + ((locale) + locale)) + (lint-warning-message-locales-for-revision conn commit-hash)))))) (if (any-invalid-query-parameters? query-parameters) (case (most-appropriate-mime-type @@ -1125,69 +1248,75 @@ '() lint-checker-options lint-warnings-locale-options + #t ; any-translated-lint-warnings? #:path-base path-base #:header-text header-text #:header-link header-link)))) - (let* ((locale (assq-ref query-parameters 'locale)) - (package-query (assq-ref query-parameters 'package_query)) - (linters (assq-ref query-parameters 'linter)) - (message-query (assq-ref query-parameters 'message_query)) - (fields (assq-ref query-parameters 'field)) - (git-repositories - (git-repositories-containing-commit conn - commit-hash)) + (let ((locale (assq-ref query-parameters 'locale)) + (package-query (assq-ref query-parameters 'package_query)) + (linters (assq-ref query-parameters 'linter)) + (message-query (assq-ref query-parameters 'message_query)) + (fields (assq-ref query-parameters 'field))) + (letpar& + ((git-repositories + (with-thread-postgresql-connection + (lambda (conn) + (git-repositories-containing-commit conn + commit-hash)))) (lint-warnings - (lint-warnings-for-guix-revision conn commit-hash - #:locale locale - #:package-query package-query - #:linters linters - #:message-query message-query)) - (any-translated-lint-warnings? - (any-translated-lint-warnings? lint-warnings locale))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((revision - . ((commit . ,commit-hash))) - (lint_warnings - . ,(list->vector - (map (match-lambda - ((id lint-checker-name lint-checker-description - lint-checker-description-locale - lint-checker-network-dependent - package-name package-version - file line-number column-number - message message-locale) - `((package . ((name . ,package-name) - (version . ,package-version))) - ,@(if (member "message" fields) - `((message . ,message) - (message-locale . ,message-locale)) - '()) - ,@(if (member "linter" fields) - `((lint-checker-description . ,lint-checker-description) - (lint-checker-description-locale . ,lint-checker-description-locale)) - '()) - ,@(if (member "location" fields) - `((location . ((file . ,file) - (line-number . ,line-number) - (column-number . ,column-number)))) - '())))) - lint-warnings)))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (view-revision-lint-warnings commit-hash - query-parameters - lint-warnings - git-repositories - lint-checker-options - lint-warnings-locale-options - any-translated-lint-warnings? - #:path-base path-base - #:header-text header-text - #:header-link header-link) - #:extra-headers http-headers-for-unchanging-content)))))) + (with-thread-postgresql-connection + (lambda (conn) + (lint-warnings-for-guix-revision conn commit-hash + #:locale locale + #:package-query package-query + #:linters linters + #:message-query message-query))))) + (let ((any-translated-lint-warnings? + (any-translated-lint-warnings? lint-warnings locale))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((revision + . ((commit . ,commit-hash))) + (lint_warnings + . ,(list->vector + (map (match-lambda + ((id lint-checker-name lint-checker-description + lint-checker-description-locale + lint-checker-network-dependent + package-name package-version + file line-number column-number + message message-locale) + `((package . ((name . ,package-name) + (version . ,package-version))) + ,@(if (member "message" fields) + `((message . ,message) + (message-locale . ,message-locale)) + '()) + ,@(if (member "linter" fields) + `((lint-checker-description . ,lint-checker-description) + (lint-checker-description-locale . ,lint-checker-description-locale)) + '()) + ,@(if (member "location" fields) + `((location . ((file . ,file) + (line-number . ,line-number) + (column-number . ,column-number)))) + '())))) + lint-warnings)))) + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (view-revision-lint-warnings commit-hash + query-parameters + lint-warnings + git-repositories + lint-checker-options + lint-warnings-locale-options + any-translated-lint-warnings? + #:path-base path-base + #:header-text header-text + #:header-link header-link) + #:extra-headers http-headers-for-unchanging-content))))))))