diff options
Diffstat (limited to 'guix-data-service/web')
| -rw-r--r-- | guix-data-service/web/build-server/controller.scm | 159 |
1 files changed, 105 insertions, 54 deletions
diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm index 2514f53..7c2ace6 100644 --- a/guix-data-service/web/build-server/controller.scm +++ b/guix-data-service/web/build-server/controller.scm @@ -20,6 +20,7 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (json) + #:use-module (fibers) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) @@ -29,6 +30,7 @@ #:use-module (guix-data-service model build) #:use-module (guix-data-service model build-server) #:use-module (guix-data-service model build-status) + #:use-module (guix-data-service model blocked-builds) #:use-module (guix-data-service model nar) #:use-module (guix-data-service model build-server-token-seed) #:use-module (guix-data-service web util) @@ -118,63 +120,112 @@ (define build-server-id (string->number build-server-id-string)) + (define (spawn-fiber-for-build-handler handler + statuses + data + build-ids) + (let ((ids + (delete-duplicates + (filter-map + (lambda (build-id item-data) + (if (and (string=? (assoc-ref item-data "type") + "build") + (member (assoc-ref item-data "event") + statuses)) + build-id + #f)) + build-ids + data) + =))) + (unless (null? ids) + (spawn-fiber + (lambda () + (parallel-via-thread-pool-channel + (with-thread-postgresql-connection + (lambda (conn) + (handler conn ids))))))))) + (define (handle-derivation-events conn items) - (unless (null? items) - (let ((build-ids - (insert-builds - conn - build-server-id - (map (lambda (item) - (assoc-ref item "derivation")) - items) - (map (lambda (item) - (and=> - (assoc-ref item "derivation_outputs") - (lambda (outputs) - (map - (lambda (output) - `((path . ,(assoc-ref output "output")) - (hash_algorithm - . ,(or (assoc-ref output "hash_algorithm") - NULL)) - (hash . ,(or (assoc-ref output "hash") - NULL)) - (recursive . ,(assoc-ref output "recursive")))) - (vector->list outputs))))) - items) - (map (lambda (item) - (assoc-ref item "build_id")) - items)))) - (insert-build-statuses - conn - build-ids - (map - (lambda (item-data) - (list (assoc-ref item-data "timestamp") - (assoc-ref item-data "event"))) - items) - #:transaction? #f)))) + (if (null? items) + '() + (let ((build-ids + (insert-builds + conn + build-server-id + (map (lambda (item) + (assoc-ref item "derivation")) + items) + (map (lambda (item) + (and=> + (assoc-ref item "derivation_outputs") + (lambda (outputs) + (map + (lambda (output) + `((path . ,(assoc-ref output "output")) + (hash_algorithm + . ,(or (assoc-ref output "hash_algorithm") + NULL)) + (hash . ,(or (assoc-ref output "hash") + NULL)) + (recursive . ,(assoc-ref output "recursive")))) + (vector->list outputs))))) + items) + (map (lambda (item) + (assoc-ref item "build_id")) + items)))) + (insert-build-statuses + conn + build-ids + (map + (lambda (item-data) + (list (assoc-ref item-data "timestamp") + (assoc-ref item-data "event"))) + items) + #:transaction? #f) + + build-ids))) (define (process-items items) - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (with-postgresql-transaction - conn - (lambda (conn) - (handle-derivation-events - conn - (filter (lambda (item) - (let ((type (assoc-ref item "type"))) - (if type - (string=? type "build") - (begin - (simple-format - (current-error-port) - "warning: unknown type for event: ~A\n" - item) - #f)))) - items)))))))) + (define filtered-items + (filter (lambda (item) + (let ((type (assoc-ref item "type"))) + (if type + (string=? type "build") + (begin + (simple-format + (current-error-port) + "warning: unknown type for event: ~A\n" + item) + #f)))) + items)) + + (letpar& ((build-ids + (with-thread-postgresql-connection + (lambda (conn) + (with-postgresql-transaction + conn + (lambda (conn) + (handle-derivation-events + conn + filtered-items))))))) + + (spawn-fiber-for-build-handler + handle-removing-blocking-build-entries-for-successful-builds + '("succeeded") + items + build-ids) + + (spawn-fiber-for-build-handler + handle-populating-blocked-builds-for-scheduled-builds + '("scheduled") + items + build-ids) + + (spawn-fiber-for-build-handler + handle-populating-blocked-builds-for-build-failures + '("failed" "failed-dependency" "canceled") + items + build-ids))) (if (any-invalid-query-parameters? parsed-query-parameters) (render-json |