diff options
Diffstat (limited to 'guix-build-coordinator/client-communication.scm')
| -rw-r--r-- | guix-build-coordinator/client-communication.scm | 184 |
1 files changed, 131 insertions, 53 deletions
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm index 80d8c96..6ec6578 100644 --- a/guix-build-coordinator/client-communication.scm +++ b/guix-build-coordinator/client-communication.scm @@ -32,6 +32,11 @@ #:use-module (json) #:use-module (logging logger) #:use-module (gcrypt random) + #:use-module (knots) + #:use-module (knots timeout) + #:use-module (knots web-server) + #:use-module (knots thread-pool) + #:use-module (prometheus) #:use-module (web uri) #:use-module (web client) #:use-module (web request) @@ -65,9 +70,10 @@ (define (start-client-request-server secret-key-base host port - build-coordinator) - (run-server/patched - (lambda (request body) + build-coordinator + utility-thread-pool) + (run-knots-web-server + (lambda (request) (log-msg (build-coordinator-logger build-coordinator) 'INFO (format #f "~4a ~a\n" @@ -78,9 +84,10 @@ (cons (request-method request) (split-and-decode-uri-path (uri-path (request-uri request)))) - body + (read-request-body request) secret-key-base - build-coordinator))) + build-coordinator + utility-thread-pool))) #:host host #:port port)) @@ -88,7 +95,8 @@ method-and-path-components raw-body secret-key-base - build-coordinator) + build-coordinator + utility-thread-pool) (define datastore (build-coordinator-datastore build-coordinator)) @@ -97,6 +105,14 @@ (json-string->scm (utf8->string raw-body)) '())) + (define read-drv-error-count-metric + (or (metrics-registry-fetch-metric + (build-coordinator-metrics-registry build-coordinator) + "read_derivation_error_total") + (make-counter-metric + (build-coordinator-metrics-registry build-coordinator) + "read_derivation_error_total"))) + (define (controller-thunk) (match method-and-path-components (('GET "build" uuid) @@ -151,7 +167,8 @@ (alist-delete 'end-time build-details)) - ,@(if (assq-ref build-details 'processed) + ,@(if (or (assq-ref build-details 'processed) + (assq-ref build-details 'canceled)) '() (datastore-find-unprocessed-build-entry datastore uuid)) (created-at . ,(or (and=> @@ -291,8 +308,8 @@ (render-json `((build_allocation_plan . ,(list->vector - (datastore-list-allocation-plan-builds - datastore + (build-coordinator-list-allocation-plan-builds + build-coordinator agent-id))))))) (('POST "agent" agent-id "passwords") (let ((password (new-agent-password @@ -401,6 +418,14 @@ (or (and=> (assq-ref query-parameters 'priority_lt) string->number) 'unset) + #:created-at-> + (or (and=> (assq-ref query-parameters 'created_at_gt) + datastore-validate-datetime-string) + 'unset) + #:created-at-< + (or (and=> (assq-ref query-parameters 'created_at_lt) + datastore-validate-datetime-string) + 'unset) #:relationship (or (and=> (assq-ref query-parameters 'relationship) string->symbol) @@ -460,14 +485,42 @@ (simple-format #f "derivation must be a string: ~A\n" derivation)))) + (unless (derivation-path? derivation-file) + (raise-exception + (make-exception-with-message + "invalid derivation path"))) + + (string-for-each + (lambda (c) + (unless (or (char-alphabetic? c) + (char-numeric? c) + (member c '(#\+ #\- #\. #\_ #\? #\=))) + (raise-exception + (make-exception-with-message + (simple-format #f "invalid character in derivation name: ~A" + c))))) + (store-path-base derivation-file)) + (define (read-drv/substitute derivation-file) - (with-store store - (ensure-non-blocking-store-connection store) - (unless (valid-path? store derivation-file) - (substitute-derivation store - derivation-file - #:substitute-urls substitute-urls))) - (read-derivation-from-file* derivation-file)) + (call-with-delay-logging + (lambda () + (with-store/non-blocking store + (unless (valid-path? store derivation-file) + (with-port-timeouts + (lambda () + (substitute-derivation store + derivation-file + #:substitute-urls substitute-urls)) + #:timeout 60))))) + ;; Read the derivation in a thread to avoid blocking fibers + (call-with-thread + utility-thread-pool + (lambda () + (read-derivation-from-file* derivation-file)) + #:duration-logger + (lambda (duration) + (log-delay read-derivation-from-file* + duration)))) (let ((submit-build-result (call-with-delay-logging @@ -476,28 +529,36 @@ `(,build-coordinator ,derivation-file #:read-drv - ,(lambda (derivation-file) - (with-exception-handler - (lambda (exn) - (log-msg - (build-coordinator-logger build-coordinator) - 'WARN - "exception substituting derivation " derivation-file - ": " exn) - - (if (null? (or substitute-urls '())) - ;; Try again - (read-drv/substitute derivation-file) - (read-derivation-through-substitutes - derivation-file - substitute-urls))) - (lambda () - (with-throw-handler #t - (lambda () - (read-drv/substitute derivation-file)) - (lambda args - (backtrace)))) - #:unwind? #t)) + ,(let ((memoized-drv #f)) + (lambda (derivation-file) + (or + memoized-drv + (with-exception-handler + (lambda (exn) + (log-msg + (build-coordinator-logger build-coordinator) + 'WARN + "exception substituting derivation " derivation-file + ": " exn) + (raise-exception exn)) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (let ((result + (retry-on-error + (lambda () + (read-drv/substitute derivation-file)) + #:times 2 + #:delay 3 + #:error-hook + (lambda _ + (metric-increment read-drv-error-count-metric))))) + (set! memoized-drv result) + result)))) + #:unwind? #t)))) ,@(let ((priority (assoc-ref body "priority"))) (if priority `(#:priority ,priority) @@ -512,6 +573,10 @@ body "ensure-all-related-derivation-outputs-have-builds") '(#:ensure-all-related-derivation-outputs-have-builds? #t) '()) + ,@(if (assoc-ref + body "skip-updating-derived-priorities") + '(#:skip-updating-derived-priorities? #t) + '()) ,@(if (assoc-ref body "tags") `(#:tags ,(map @@ -535,8 +600,7 @@ datastore (lambda (_) (let ((allocation-plan-counts - (datastore-count-build-allocation-plan-entries - datastore))) + (build-coordinator-allocation-plan-stats build-coordinator))) `((state_id . ,(build-coordinator-get-state-id build-coordinator)) (agents . ,(list->vector (map @@ -586,7 +650,9 @@ (datastore-list-agent-builds datastore (assq-ref agent-details 'uuid)))))))) - (datastore-list-agents datastore)))))))))) + (datastore-list-agents datastore))))))) + #:priority 'high + #:duration-metric-name "get_state"))) (('GET "events") (let ((headers (request-headers request))) (list (build-response @@ -631,7 +697,7 @@ (render-json `((error . ,(client-error-details exn))) #:code 400)) - ((worker-thread-timeout-error? exn) + ((thread-pool-timeout-error? exn) (render-json `((error . ,(simple-format #f "~A" exn))) #:code 503)) @@ -640,20 +706,18 @@ `((error . 500)) #:code 500)))) (lambda () - (with-throw-handler #t - controller-thunk - (lambda (key . args) - (unless (and (eq? '%exception key) - (or - (worker-thread-timeout-error? (car args)) - (client-error? (car args)))) + (with-exception-handler + (lambda (exn) + (unless (or + (thread-pool-timeout-error? exn) + (client-error? exn)) (match method-and-path-components ((method path-components ...) (simple-format (current-error-port) - "error: when processing client request: /~A ~A\n ~A ~A\n" + "error: when processing client request: /~A ~A\n ~A\n" method (string-join path-components "/") - key args))) + exn))) (let* ((stack (make-stack #t 4)) (backtrace @@ -665,7 +729,9 @@ (newline port))))) (display backtrace - (current-error-port))))))) + (current-error-port)))) + (raise-exception exn)) + controller-thunk)) #:unwind? #t)) (define* (render-json json #:key (extra-headers '()) @@ -753,7 +819,8 @@ ensure-all-related-derivation-outputs-have-builds? tags #:key - defer-until) + defer-until + skip-updating-derived-priorities?) (send-request coordinator-uri 'POST "/builds" @@ -771,6 +838,9 @@ ,@(if ensure-all-related-derivation-outputs-have-builds? '((ensure-all-related-derivation-outputs-have-builds . #t)) '()) + ,@(if skip-updating-derived-priorities? + '((skip-updating-derived-priorities . #t)) + '()) ,@(if (null? tags) '() `((tags . ,(list->vector tags)))) @@ -831,6 +901,8 @@ (canceled 'unset) (priority-> 'unset) (priority-< 'unset) + (created-at-> 'unset) + (created-at-< 'unset) (relationship 'unset) (after-id #f) (limit #f)) @@ -879,6 +951,12 @@ ,@(if (number? priority-<) (list (simple-format #f "priority_lt=~A" priority-<)) '()) + ,@(if (string? created-at->) + (list (simple-format #f "created_at_gt=~A" created-at->)) + '()) + ,@(if (string? created-at-<) + (list (simple-format #f "created_at_lt=~A" created-at-<)) + '()) ,@(if (and relationship (not (eq? 'unset relationship))) (list (simple-format #f "relationship=~A" relationship)) '()) |