aboutsummaryrefslogtreecommitdiff
path: root/guix-build-coordinator/agent-messaging/http/server.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix-build-coordinator/agent-messaging/http/server.scm')
-rw-r--r--guix-build-coordinator/agent-messaging/http/server.scm449
1 files changed, 449 insertions, 0 deletions
diff --git a/guix-build-coordinator/agent-messaging/http/server.scm b/guix-build-coordinator/agent-messaging/http/server.scm
new file mode 100644
index 0000000..3038be0
--- /dev/null
+++ b/guix-build-coordinator/agent-messaging/http/server.scm
@@ -0,0 +1,449 @@
+;;; Guix Build Coordinator
+;;;
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of the guix-build-coordinator.
+;;;
+;;; The Guix Build Coordinator is free software; you can redistribute
+;;; it and/or modify it under the terms of the GNU General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; The Guix Build Coordinator is distributed in the hope that it will
+;;; be useful, but WITHOUT ANY WARRANTY; without even the implied
+;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+;;; See the GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-build-coordinator agent-messaging http server)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 exceptions)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (system repl error-handling)
+ #:use-module (rnrs bytevectors)
+ #:use-module (json)
+ #:use-module (web http)
+ #:use-module (web client)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:use-module (prometheus)
+ #:use-module (guix base64)
+ #: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))
+
+(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))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-05-19 07:26:02 +0000