diff options
Diffstat (limited to 'guix-build-coordinator/agent-messaging/http.scm')
| -rw-r--r-- | guix-build-coordinator/agent-messaging/http.scm | 410 |
1 files changed, 1 insertions, 409 deletions
diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm index 1f0f1a9..202b90e 100644 --- a/guix-build-coordinator/agent-messaging/http.scm +++ b/guix-build-coordinator/agent-messaging/http.scm @@ -42,12 +42,9 @@ #:use-module (guix serialization) #:use-module (guix build utils) #:use-module (guix-build-coordinator utils) - #:use-module (guix-build-coordinator utils fibers) #:use-module (guix-build-coordinator datastore) #:use-module (guix-build-coordinator coordinator) - #:export (http-agent-messaging-start-server - - submit-status + #:export (submit-status submit-log-file submit-build-result report-build-start @@ -55,411 +52,6 @@ submit-output fetch-builds-for-agent)) -(define (fixed/read-request-body r) - "Reads the request body from R, as a bytevector. Return â#fâ -if there was no request body." - (cond - ((member '(chunked) (request-transfer-encoding r)) - (make-chunked-input-port* (request-port r) - ;; closing the port is handled elsewhere - #:keep-alive? #t)) - (else - (let ((nbytes (request-content-length r))) - (and nbytes - (let ((bv (get-bytevector-n (request-port r) nbytes))) - (if (= (bytevector-length bv) nbytes) - bv - (bad-request "EOF while reading request body: ~a bytes of ~a" - (bytevector-length bv) nbytes)))))))) - -(module-set! (resolve-module '(web request)) - 'read-request-body - fixed/read-request-body) - -(define (http-agent-messaging-start-server port host secret-key-base - build-coordinator - chunked-request-channel) - (define update-base-datastore-metrics! - (base-datastore-metrics-updater build-coordinator)) - - (call-with-error-handling - (lambda () - (run-server/patched - (lambda (request body) - (display - (format #f "~4a ~a\n" - (request-method request) - (uri-path (request-uri request)))) - (apply values - (controller request - (cons (request-method request) - (split-and-decode-uri-path - (uri-path (request-uri request)))) - body - secret-key-base - build-coordinator - chunked-request-channel - update-base-datastore-metrics!))) - #:host host - #:port port)) - #:on-error 'backtrace - #:post-error (lambda (key . args) - (when (eq? key 'system-error) - (match args - (("bind" "~A" ("Address already in use") _) - (simple-format - (current-error-port) - "\n -error: guix-build-coordinator could not start, as it could not bind to port ~A - -Check if it's already running, or whether another process is using that -port. Also, the port used can be changed by passing the --port option.\n" - port))))))) - -(define* (render-json json #:key (extra-headers '()) - (code 200)) - (list (build-response - #:code code - #:headers (append extra-headers - '((content-type . (application/json)) - (vary . (accept))))) - (lambda (port) - (scm->json json port)))) - -(define* (render-text text #:key (extra-headers '()) - (code 200)) - (list (build-response - #:code code - #:headers (append extra-headers - '((content-type . (text/plain)) - (vary . (accept))))) - (lambda (port) - (display text port)))) - -(define (no-content) - (list (build-response #:code 204) - "")) - -(define (base-datastore-metrics-updater build-coordinator) - (define datastore - (build-coordinator-datastore build-coordinator)) - - (define registry - (build-coordinator-metrics-registry build-coordinator)) - - (let ((builds-total - (make-gauge-metric registry "builds_total" - #:labels '(system))) - (allocated-builds-total - (make-gauge-metric registry - "allocated_builds_total" - #:labels '(agent_id))) - (build-results-total - (make-gauge-metric registry - "build_results_total" - #:labels '(agent_id result))) - (setup-failures-total - (make-gauge-metric registry - "setup_failures_total" - #:labels '(agent_id reason))) - (build-allocation-plan-total - (make-gauge-metric registry - "build_allocation_plan_total" - #:labels '(agent_id))) - (unprocessed-hook-events-total - (make-gauge-metric registry - "unprocessed_hook_events_total" - #:labels '(event)))) - (define (zero-metric-for-agents metric) - (for-each (lambda (agent-details) - (metric-set metric - 0 - #:label-values - `((agent_id . ,(assq-ref agent-details 'uuid))))) - (datastore-list-agents datastore))) - - (lambda () - (for-each (match-lambda - ((system . count) - (metric-set builds-total - count - #:label-values - `((system . ,system))))) - (datastore-count-builds datastore)) - - (zero-metric-for-agents allocated-builds-total) - (for-each (match-lambda - ((agent-id . count) - (metric-set allocated-builds-total - count - #:label-values - `((agent_id . ,agent-id))))) - (datastore-count-allocated-builds datastore)) - (for-each (match-lambda - (((agent-id result) . count) - (metric-set build-results-total - count - #:label-values - `((agent_id . ,agent-id) - (result . ,result))))) - (datastore-count-build-results datastore)) - (for-each (match-lambda - (((agent-id reason) . count) - (metric-set setup-failures-total - count - #:label-values - `((agent_id . ,agent-id) - (reason . ,reason))))) - (datastore-count-setup-failures datastore)) - (zero-metric-for-agents build-allocation-plan-total) - (for-each (match-lambda - ((agent-id . count) - (metric-set build-allocation-plan-total - count - #:label-values - `((agent_id . ,agent-id))))) - (datastore-count-build-allocation-plan-entries datastore)) - - (for-each (match-lambda - ((event . _) - (metric-set unprocessed-hook-events-total - 0 - #:label-values - `((event . ,event))))) - (build-coordinator-hooks build-coordinator)) - (for-each (lambda (event-count) - (metric-set unprocessed-hook-events-total - (assq-ref event-count 'count) - #:label-values - `((event . ,(assq-ref event-count 'event))))) - (datastore-count-unprocessed-hook-events datastore))))) - -(define (controller request - method-and-path-components - body - secret-key-base - build-coordinator - chunked-request-channel - update-base-datastore-metrics!) - (define (authenticated? uuid request) - (let* ((authorization-base64 - (match (assq-ref (request-headers request) - 'authorization) - (('basic . s) s))) - (authorization - (utf8->string - (base64-decode authorization-base64)))) - (match (string-split authorization #\:) - ((auth-uuid auth-password) - (and - (string? uuid) - (string=? auth-uuid uuid) - (datastore-agent-password-exists? datastore - uuid - auth-password))) - (_ #f)))) - - (define datastore - (build-coordinator-datastore build-coordinator)) - - (define (controller-thunk) - (match method-and-path-components - (('GET "agent" uuid) - (let ((agent (datastore-find-agent datastore uuid))) - (if agent - (render-json - `((agent . ,uuid) - ,@agent)) - (render-json - (simple-format #f "no agent found with id: ~A" - uuid) - #:code 404)))) - (('PUT "agent" uuid) - (if (authenticated? uuid request) - (begin - ;; TODO Update status - (render-json - (agent-details datastore uuid))) - (render-json - '(("error" . "access denied")) - #:code 403))) - (('POST "agent" uuid "fetch-builds") - (if (authenticated? uuid request) - (let* ((json-body (json-string->scm (utf8->string body))) - (count (assoc-ref json-body "count")) - (systems (assoc-ref json-body "systems")) - (builds (fetch-builds build-coordinator uuid - (vector->list systems) - count))) - (render-json - `((builds . ,(list->vector builds))))) - (render-json - '(("error" . "access denied")) - #:code 403))) - (('PUT "build" uuid) - (let ((agent-id-for-build - (datastore-agent-for-build datastore uuid))) - (if (authenticated? agent-id-for-build request) - (begin - (handle-build-result build-coordinator - agent-id-for-build uuid - (json-string->scm (utf8->string body))) - ;; Trigger build allocation, as the result of this build - ;; could change the allocation - (trigger-build-allocation build-coordinator) - (render-json - "message received")) - (render-json - '(("error" . "access denied")) - #:code 403)))) - (('POST "build" uuid "report-build-start") - (let ((agent-id-for-build - (datastore-agent-for-build datastore uuid))) - (if (authenticated? agent-id-for-build request) - (begin - (handle-build-start-report datastore - agent-id-for-build - uuid) - (render-json - "message received")) - (render-json - '(("error" . "access denied")) - #:code 403)))) - (('POST "build" uuid "report-setup-failure") - (let ((agent-id-for-build - (datastore-agent-for-build datastore uuid))) - (if (authenticated? agent-id-for-build request) - (begin - (handle-setup-failure-report - datastore - agent-id-for-build uuid - (json-string->scm (utf8->string body))) - ;; Trigger build allocation, so that the allocator can handle - ;; this setup failure - (trigger-build-allocation build-coordinator) - (render-json - "message received")) - (render-json - '(("error" . "access denied")) - #:code 403)))) - (('PUT "build" uuid "log" format) - (let ((agent-id-for-build - (datastore-agent-for-build datastore uuid))) - (if (authenticated? agent-id-for-build request) - (let ((output-file-name - (build-log-file-location datastore uuid format))) - (mkdir-p (dirname output-file-name)) - (if (call-with-worker-thread - chunked-request-channel - (lambda () - (call-with-output-file output-file-name - (lambda (output-port) - (let loop ((bv (get-bytevector-some body))) - (unless (eof-object? bv) - (put-bytevector output-port bv) - (loop (get-bytevector-some body)))))) - #t)) - (no-content) - (render-json - "error" - #:code 500))) - (render-json - '(("error" . "access denied")) - #:code 403)))) - (('PUT "build" uuid "output" output-name) - (let ((agent-id-for-build - (datastore-agent-for-build datastore uuid))) - (if (authenticated? agent-id-for-build request) - (let* ((output-file-name - (build-output-file-location datastore uuid output-name)) - (tmp-output-file-name - (string-append output-file-name ".tmp"))) - (mkdir-p (dirname output-file-name)) - (when (file-exists? tmp-output-file-name) - (delete-file tmp-output-file-name)) - (if (call-with-worker-thread - chunked-request-channel - (lambda () - (call-with-output-file tmp-output-file-name - (lambda (output-port) - (let ((start-time (current-time time-utc))) - (let loop ((bv (get-bytevector-some body)) - (bytes-read 0) - (last-progress-update-bytes-read 0)) - (if (eof-object? bv) - (let* ((end-time (current-time time-utc)) - (elapsed (time-difference end-time - start-time)) - (seconds-elapsed - (+ (time-second elapsed) - (/ (time-nanosecond elapsed) 1e9)))) - (display - (simple-format - #f - "receiving ~A\n took ~A seconds\n data transfered: ~AMB\n speed (MB/s): ~A\n" - (basename output-file-name) - seconds-elapsed - (rationalize (exact->inexact (/ bytes-read 1000000)) - 0.1) - (rationalize (/ (/ bytes-read 1000000) seconds-elapsed) - 0.1)))) - (begin - (put-bytevector output-port bv) - (loop (get-bytevector-some body) - (+ bytes-read - (bytevector-length bv)) - (if (> (- bytes-read - last-progress-update-bytes-read) - 50000000) ; ~50MB - (begin - (display - (simple-format - #f "receiving ~A\n ~AMB read so far...\n" - (basename output-file-name) - (rationalize (exact->inexact (/ bytes-read - 1000000)) - 0.1))) - bytes-read) - last-progress-update-bytes-read)))))))) - (rename-file tmp-output-file-name - output-file-name) - #t)) - (no-content) - (render-json - "error" - #:code 500))) - (render-json - '(("error" . "access denied")) - #:code 403)))) - (('GET "metrics") - (update-base-datastore-metrics!) - (list (build-response - #:code 200 - #:headers '((content-type . (text/plain)) - (vary . (accept)))) - (lambda (port) - (write-metrics (build-coordinator-metrics-registry - build-coordinator) - port)))) - (_ - (render-json - "not-found" - #:code 404)))) - - (call-with-error-handling - controller-thunk - #:on-error 'backtrace - #:post-error (lambda args - (match method-and-path-components - ((method path-components ...) - (simple-format - (current-error-port) - "error: when processing: /~A ~A\n" - method (string-join path-components "/")))) - (render-json - `((error . ,(simple-format #f "~A" args))) - #:code 500)))) - (define (coordinator-uri-for-path base-uri-string agent-path) (let* ((base-uri (string->uri base-uri-string)) (scheme (uri-scheme base-uri)) |