diff options
Diffstat (limited to 'guix-build-coordinator/agent-messaging/http/server.scm')
| -rw-r--r-- | guix-build-coordinator/agent-messaging/http/server.scm | 136 |
1 files changed, 48 insertions, 88 deletions
diff --git a/guix-build-coordinator/agent-messaging/http/server.scm b/guix-build-coordinator/agent-messaging/http/server.scm index 85ba0d4..fa227da 100644 --- a/guix-build-coordinator/agent-messaging/http/server.scm +++ b/guix-build-coordinator/agent-messaging/http/server.scm @@ -46,13 +46,15 @@ #:use-module (fibers timers) #:use-module (fibers channels) #:use-module (fibers operations) + #:use-module (knots) + #:use-module (knots timeout) + #:use-module (knots web-server) + #:use-module (knots thread-pool) #:use-module (prometheus) #:use-module (guix base32) #:use-module (guix base64) #:use-module (guix progress) #:use-module (guix build utils) - #:use-module ((guix build syscalls) - #:select (set-thread-name)) #:use-module (guix-build-coordinator utils) #:use-module (guix-build-coordinator utils fibers) #:use-module (guix-build-coordinator datastore) @@ -135,7 +137,6 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." (define (http-agent-messaging-start-server port host secret-key-base build-coordinator - chunked-request-channel output-hash-channel) (define plain-metrics-registry (make-metrics-registry)) @@ -146,18 +147,15 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." (define process-metrics-updater (get-process-metrics-updater plain-metrics-registry)) - (define thread-metric - (make-gauge-metric - (build-coordinator-metrics-registry build-coordinator) - "guile_threads_total")) - (define datastore-metrics-updater (base-datastore-metrics-updater build-coordinator)) + (define (build-coordinator-metrics-updater) + (build-coordinator-update-metrics build-coordinator)) + (define (update-managed-metrics!) + (call-with-delay-logging build-coordinator-metrics-updater) (call-with-delay-logging gc-metrics-updater) - (metric-set thread-metric - (length (all-threads))) (call-with-delay-logging process-metrics-updater) (call-with-delay-logging datastore-metrics-updater)) @@ -168,8 +166,8 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." "exception when starting: ~A\n" exn) (primitive-exit 1)) (lambda () - (run-server/patched - (lambda (request body) + (run-knots-web-server + (lambda (request) (log-msg (build-coordinator-logger build-coordinator) 'INFO (format #f "~4a ~a\n" @@ -180,10 +178,8 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." (cons (request-method request) (split-and-decode-uri-path (uri-path (request-uri request)))) - body secret-key-base build-coordinator - chunked-request-channel output-hash-channel update-managed-metrics! plain-metrics-registry))) @@ -611,10 +607,8 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." (define (controller request method-and-path-components - body secret-key-base build-coordinator - chunked-request-channel output-hash-channel update-managed-metrics! plain-metrics-registry) @@ -642,6 +636,10 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." (define logger (build-coordinator-logger build-coordinator)) + ;; TODO Handle this in the controller + (define body + (read-request-body request)) + (define (controller-thunk) (match method-and-path-components (('GET "agent" uuid) @@ -710,14 +708,11 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." (('POST "agent" uuid "fetch-builds") (if (authenticated? uuid request) (let* ((json-body (json-string->scm (utf8->string body))) - ;; count is deprecated, use target_count instead - (count (assoc-ref json-body "count")) (target-count (assoc-ref json-body "target_count")) (systems (assoc-ref json-body "systems")) (builds (fetch-builds build-coordinator uuid (vector->list systems) - target-count - count))) + target-count))) (render-json `((builds . ,(list->vector builds))))) (render-json @@ -794,18 +789,9 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." body))) (call-with-output-file tmp-output-file-name (lambda (output-port) - ;; Older agents may still attempt to use chunked encoding - ;; for this request - (if (member '(chunked) (request-transfer-encoding request)) - (call-with-worker-thread - chunked-request-channel - (lambda () - (dump-port body-port - output-port - (request-content-length request)))) - (dump-port body-port - output-port - (request-content-length request)))))) + (dump-port body-port + output-port + (request-content-length request))))) (rename-file tmp-output-file-name output-file-name) (no-content)) @@ -852,20 +838,12 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." "deleting " tmp-output-file-name) (delete-file tmp-output-file-name)) - (if (member '(chunked) (request-transfer-encoding request)) - ;; Older agents may use chunked encoding for this request - (call-with-worker-thread - chunked-request-channel - (lambda () - (receive-file body - #f - tmp-output-file-name))) - (let ((content-length - (request-content-length request))) - (when (> content-length 0) - (receive-file body - content-length - tmp-output-file-name)))) + (let ((content-length + (request-content-length request))) + (when (> content-length 0) + (receive-file body + content-length + tmp-output-file-name))) (if (file-exists? output-file-name) (render-json @@ -945,19 +923,10 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." "deleting " output-file-name) (delete-file output-file-name)) - (if (member '(chunked) (request-transfer-encoding request)) - ;; Older agents may use chunked encoding for this request - (call-with-worker-thread - chunked-request-channel - (lambda () - (receive-file body - #f - tmp-output-file-name - #:append? #t))) - (receive-file body - (request-content-length request) - tmp-output-file-name - #:append? #t))) + (receive-file body + content-length + tmp-output-file-name + #:append? #t)) (if (file-exists? output-file-name) (render-json @@ -1015,12 +984,13 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." #:code 200 #:headers '((content-type . (text/plain)) (vary . (accept)))) - (lambda (port) - (write-metrics (build-coordinator-metrics-registry - build-coordinator) - port) - (write-metrics plain-metrics-registry - port)))))) + (call-with-output-string + (lambda (port) + (write-metrics (build-coordinator-metrics-registry + build-coordinator) + port) + (write-metrics plain-metrics-registry + port))))))) (_ (render-json "not-found" @@ -1037,7 +1007,7 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." (render-json `((error . chunked-input-ended-prematurely)) #:code 400)) - ((worker-thread-timeout-error? exn) + ((thread-pool-timeout-error? exn) (render-json `((error . ,(simple-format #f "~A" exn))) #:code 503)) @@ -1046,30 +1016,20 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." `((error . ,(simple-format #f "~A" exn))) #:code 500)))) (lambda () - (with-throw-handler #t - controller-thunk - (lambda (key . args) - (unless (and (eq? '%exception key) - (or (agent-error? (car args)) - (worker-thread-timeout-error? (car args)) - (chunked-input-ended-prematurely-error? (car args)))) + (with-exception-handler + (lambda (exn) + (unless (or (agent-error? exn) + (thread-pool-timeout-error? exn) + (chunked-input-ended-prematurely-error? exn)) (match method-and-path-components ((method path-components ...) (simple-format (current-error-port) - "error: when processing: /~A ~A\n ~A ~A\n" - method (string-join path-components "/") - key args))) - - (let* ((stack (make-stack #t 4)) - (backtrace - (call-with-output-string - (lambda (port) - (display "\nBacktrace:\n" port) - (display-backtrace stack port) - (newline port) - (newline port))))) - (display - backtrace - (current-error-port))))))) + "error: when processing: /~A ~A\n" + method (string-join path-components "/")))) + + (print-backtrace-and-exception/knots exn)) + + (raise-exception exn)) + controller-thunk)) #:unwind? #t)) |