guix
/
data-service
mirror of git://git.savannah.gnu.org/guix/data-service.git
2
0
Fork 0
Code Issues Releases Wiki Activity

Instrument handling build events

This commit is contained in:
Christopher Baines 2023-11-24 16:11:42 +00:00
parent e13febc817
commit 241a704db1
2 changed files with 64 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
guix-data-service/web/build-server/controller.scm
View File

@ -21,9 +21,11 @@
#:use-module (rnrs bytevectors)
#:use-module (json)
#:use-module (fibers)
#:use-module (prometheus)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service substitutes)
#:use-module (guix-data-service web server)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web controller)
@ -255,56 +257,60 @@
(render-json
'((error . "no token provided"))
#:code 400)
(let ((provided-token (assq-ref parsed-query-parameters 'token))
(permitted-tokens
(with-resource-from-pool (reserved-connection-pool) conn
(compute-tokens-for-build-server conn
secret-key-base
build-server-id))))
(if (member provided-token
(map cdr permitted-tokens)
string=?)
(catch
'json-invalid
(lambda ()
(let ((body-string (utf8->string body)))
(let* ((body-json (json-string->scm body-string))
(items (and=> (assoc-ref body-json "items")
vector->list)))
(cond
((eq? items #f)
(render-json
'((error . "missing items key"))
#:code 400))
((null? items)
(render-json
'((error . "no items to process"))
#:code 400))
(else
(catch
#t
(lambda ()
(process-items items)
(no-content))
(lambda (key . args)
(simple-format (current-error-port)
"error processing events: ~A: ~A\n"
key
args)
(for-each (lambda (item)
(simple-format (current-error-port)
" ~A\n" item))
items)
(render-json
'((error . "could not process events"))
#:code 500))))))))
(lambda (key . args)
(render-json
'((error . "could not parse body as JSON"))
#:code 400)))
(render-json
'((error . "error"))
#:code 403)))))
(call-with-duration-metric
(%guix-data-service-metrics-registry)
"build_server_handle_events_submission_duration_seconds"
(lambda ()
(let ((provided-token (assq-ref parsed-query-parameters 'token))
(permitted-tokens
(with-resource-from-pool (reserved-connection-pool) conn
(compute-tokens-for-build-server conn
secret-key-base
build-server-id))))
(if (member provided-token
(map cdr permitted-tokens)
string=?)
(catch
'json-invalid
(lambda ()
(let ((body-string (utf8->string body)))
(let* ((body-json (json-string->scm body-string))
(items (and=> (assoc-ref body-json "items")
vector->list)))
(cond
((eq? items #f)
(render-json
'((error . "missing items key"))
#:code 400))
((null? items)
(render-json
'((error . "no items to process"))
#:code 400))
(else
(catch
#t
(lambda ()
(process-items items)
(no-content))
(lambda (key . args)
(simple-format (current-error-port)
"error processing events: ~A: ~A\n"
key
args)
(for-each (lambda (item)
(simple-format (current-error-port)
" ~A\n" item))
items)
(render-json
'((error . "could not process events"))
#:code 500))))))))
(lambda (key . args)
(render-json
'((error . "could not parse body as JSON"))
#:code 400)))
(render-json
'((error . "error"))
#:code 403)))))))
(define (handle-signing-key-request id)
(render-html

9
guix-data-service/web/server.scm
View File

@ -35,7 +35,9 @@
#:use-module (guix-data-service database)
#:use-module (guix-data-service web controller)
#:use-module (guix-data-service web util)
#:export (start-guix-data-service-web-server))
#:export (%guix-data-service-metrics-registry
start-guix-data-service-web-server))
(define (check-startup-completed startup-completed)
(if (atomic-box-ref startup-completed)
@ -64,6 +66,9 @@
(check-startup-completed startup-completed)
render-metrics))))
(define %guix-data-service-metrics-registry
(make-parameter #f))
(define* (start-guix-data-service-web-server port host secret-key-base
startup-completed
#:key postgresql-statement-timeout
@ -73,6 +78,8 @@
(%database-metrics-registry registry)
(%guix-data-service-metrics-registry registry)
(let ((finished? (make-condition)))
(call-with-sigint
(lambda ()