diff options
Diffstat (limited to 'guix-data-service/web/controller.scm')
| -rw-r--r-- | guix-data-service/web/controller.scm | 75 |
1 files changed, 32 insertions, 43 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index d503052..1c2c589 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -35,6 +35,9 @@ #:use-module (texinfo html) #:use-module (squee) #:use-module (json) + #:use-module (fibers) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (prometheus) #:use-module (guix-data-service utils) #:use-module (guix-data-service config) @@ -75,9 +78,13 @@ make-render-metrics controller + background-connection-pool connection-pool reserved-connection-pool)) +(define background-connection-pool + (make-parameter #f)) + (define connection-pool (make-parameter #f)) @@ -176,7 +183,8 @@ (resource-pools `(("normal" . ,(connection-pool)) - ("reserved" . ,(reserved-connection-pool)))) + ("reserved" . ,(reserved-connection-pool)) + ("background" . ,(background-connection-pool)))) (resource-pool-metrics `((resources . ,(make-gauge-metric @@ -229,7 +237,7 @@ #:always-rollback? #t)) (lambda () - (letpar& ((metric-values + (fibers-let ((metric-values (with-exception-handler (lambda (exn) (simple-format @@ -451,23 +459,23 @@ (write-metrics registry port)))))))) (define (render-derivation derivation-file-name) - (letpar& ((derivation - (with-resource-from-pool (reserved-connection-pool) conn + (fibers-let ((derivation + (with-resource-from-pool (connection-pool) conn (select-derivation-by-file-name conn derivation-file-name)))) (if derivation - (letpar& ((derivation-inputs - (with-resource-from-pool (reserved-connection-pool) conn + (fibers-let ((derivation-inputs + (with-resource-from-pool (connection-pool) conn (select-derivation-inputs-by-derivation-id conn (first derivation)))) (derivation-outputs - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-derivation-outputs-by-derivation-id conn (first derivation)))) (builds - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-builds-with-context-by-derivation-file-name conn (second derivation))))) @@ -486,11 +494,11 @@ (define (render-json-derivation derivation-file-name) (let ((derivation - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-derivation-by-file-name conn derivation-file-name)))) (if derivation - (letpar& ((derivation-inputs + (fibers-let ((derivation-inputs (with-resource-from-pool (connection-pool) conn (select-derivation-inputs-by-derivation-id conn @@ -546,7 +554,7 @@ (select-derivation-by-file-name conn derivation-file-name)))) (if derivation - (letpar& ((derivation-inputs + (fibers-let ((derivation-inputs (with-resource-from-pool (connection-pool) conn (select-derivation-inputs-by-derivation-id conn @@ -591,12 +599,12 @@ #:sxml (view-narinfos narinfos))))) (define (render-store-item filename) - (letpar& ((derivation - (with-resource-from-pool (reserved-connection-pool) conn + (fibers-let ((derivation + (with-resource-from-pool (connection-pool) conn (select-derivation-by-output-filename conn filename)))) (match derivation (() - (match (with-resource-from-pool (reserved-connection-pool) conn + (match (with-resource-from-pool (connection-pool) conn (select-derivation-source-file-by-store-path conn filename)) (() (render-html @@ -608,17 +616,17 @@ (render-html #:sxml (view-derivation-source-file filename - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-derivation-source-file-nar-details-by-file-name conn filename))) #:extra-headers http-headers-for-unchanging-content)))) (derivations - (letpar& ((nars - (with-resource-from-pool (reserved-connection-pool) conn + (fibers-let ((nars + (with-resource-from-pool (connection-pool) conn (select-nars-for-output conn filename))) (builds - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (select-builds-with-context-by-derivation-output conn filename)))) @@ -651,7 +659,7 @@ conn filename)))))))))) (derivations - (letpar& ((nars + (fibers-let ((nars (with-resource-from-pool (connection-pool) conn (select-nars-for-output conn filename)))) (render-json @@ -712,17 +720,9 @@ #:sxml (server-starting-up-page) #:code 503))) - (call-with-error-handling - (if startup-completed? - running-controller-thunk - startup-controller-thunk) - #:on-error 'backtrace - #:post-error (lambda args - (render-html #:sxml (error-page - (if (%show-error-details) - args - #f)) - #:code 500)))) + (if startup-completed? + (running-controller-thunk) + (startup-controller-thunk))) (define* (base-controller request method-and-path-components startup-completed?) @@ -803,7 +803,7 @@ (('GET) (render-html #:sxml (index - (with-resource-from-pool (reserved-connection-pool) conn + (with-resource-from-pool (connection-pool) conn (map (lambda (git-repository-details) (cons @@ -813,19 +813,8 @@ (all-git-repositories conn)))))) (('GET "builds") (delegate-to build-controller)) - (('GET "statistics") - (letpar& ((guix-revisions-count - (with-resource-from-pool (connection-pool) conn count-guix-revisions)) - (count-derivations - (with-resource-from-pool (connection-pool) conn count-derivations))) - - (render-html - #:sxml (view-statistics guix-revisions-count - count-derivations)))) (('GET "metrics") - (parameterize - ((resource-pool-default-timeout 6)) - (render-metrics))) + (render-metrics)) (('GET "revision" args ...) (delegate-to revision-controller)) (('GET "repositories") |