diff options
| -rw-r--r-- | bffe.scm | 3 | ||||
| -rw-r--r-- | bffe/manage-builds.scm | 98 | ||||
| -rw-r--r-- | bffe/server.scm | 15 | ||||
| -rw-r--r-- | bffe/view/build.scm | 18 | ||||
| -rw-r--r-- | guix-dev.scm | 33 |
5 files changed, 83 insertions, 84 deletions
@@ -27,8 +27,7 @@ #:use-module (fibers scheduler) #:use-module (fibers channels) #:use-module (fibers conditions) - #:use-module ((guix-build-coordinator utils fibers) - #:select (call-with-sigint)) + #:use-module (knots) #:use-module (bffe server) #:use-module (bffe manage-builds) #:export (run-bffe-service)) diff --git a/bffe/manage-builds.scm b/bffe/manage-builds.scm index caa4893..9a4bd3e 100644 --- a/bffe/manage-builds.scm +++ b/bffe/manage-builds.scm @@ -28,6 +28,8 @@ #:use-module (json) #:use-module (fibers) #:use-module (fibers channels) + #:use-module (knots queue) + #:use-module (knots parallelism) #:use-module (guix records) #:use-module (web uri) #:use-module (web response) @@ -42,6 +44,7 @@ build-from-guix-data-service-submit-builds-for-channel-instances? build-from-guix-data-service-build-keyword-arguments build-from-guix-data-service-data-service-build-server-id + build-from-guix-data-service-ignore-commits start-submit-builds-fibers)) @@ -66,7 +69,9 @@ build-from-guix-data-service-revision-parameters (default '())) (parallelism build-from-guix-data-service-parallelism - (default 2))) + (default 2)) + (ignore-commits build-from-guix-data-service-ignore-commits + (default '()))) (define-exception-type &guix-data-service-error &error make-guix-data-service-error @@ -148,7 +153,9 @@ 500)))))) (define* (fiberize proc #:key (parallelism 1)) - (let ((channel (make-channel))) + (let* ((channel (make-channel)) + (queue-channel + (spawn-queueing-fiber channel))) (for-each (lambda _ (spawn-fiber @@ -177,74 +184,11 @@ (lambda args (let ((reply-channel (make-channel))) - (put-message channel (cons reply-channel args)) + (put-message queue-channel (cons reply-channel args)) (match (get-message reply-channel) (('result . vals) (apply values vals)) (('exception . exn) (raise-exception exn))))))) -(define (fibers-map proc . lists) - (let ((channels - (apply - map - (lambda args - (let ((channel (make-channel))) - (spawn-fiber - (lambda () - (put-message - channel - (with-exception-handler - (lambda (exn) - (cons 'exception exn)) - (lambda () - (with-throw-handler #t - (lambda () - (call-with-values - (lambda () - (apply proc args)) - (lambda val - (cons 'result val)))) - (lambda _ - (backtrace)))) - #:unwind? #t)))) - channel)) - lists))) - (map - (match-lambda - (('result . val) val) - (('exception . exn) (raise-exception exn))) - (map get-message channels)))) - -(define (fibers-for-each proc . lists) - ;; Like split-at, but don't care about the order of the resulting lists, and - ;; don't error if the list is shorter than i elements - (define (split-at* lst i) - (let lp ((l lst) (n i) (acc '())) - (if (or (<= n 0) (null? l)) - (values (reverse! acc) l) - (lp (cdr l) (- n 1) (cons (car l) acc))))) - - ;; As this can be called with lists with tens of thousands of items in them, - ;; batch the - (define batch-size 20) - (define (get-batch lists) - (let ((split-lists - (map (lambda (lst) - (let ((batch rest (split-at* lst batch-size))) - (cons batch rest))) - lists))) - (values (map car split-lists) - (map cdr split-lists)))) - - (let loop ((lists lists)) - (call-with-values - (lambda () - (get-batch lists)) - (lambda (batch rest) - (apply fibers-map proc batch) - (unless (null? (car rest)) - (loop rest))))) - *unspecified*) - (define (all-repository-ids guix-data-service) (let ((data (guix-data-service-request guix-data-service "/repositories.json" @@ -453,15 +397,19 @@ (build-from-guix-data-service-revision-parameters specification) #:retry-times 3)) (unseen-revisions - (filter-map (lambda (entry) - (let ((commit (assoc-ref entry "commit-hash"))) - (and (not (hash-ref processed-commits-hash - commit)) - (assoc-ref entry "data_available") - commit))) - (vector->list - (assoc-ref branch-revisions - "revisions"))))) + (filter-map + (lambda (entry) + (let ((commit (assoc-ref entry "commit-hash"))) + (and (not (hash-ref processed-commits-hash + commit)) + (not (member + commit + (build-from-guix-data-service-ignore-commits + specification))) + (assoc-ref entry "data_available") + commit))) + (vector->list + (assoc-ref branch-revisions "revisions"))))) (log-msg 'DEBUG (length unseen-revisions) " unseen revisions") (metric-set unseen-revisions-metric (length unseen-revisions)) diff --git a/bffe/server.scm b/bffe/server.scm index eae7291..0c8c5d1 100644 --- a/bffe/server.scm +++ b/bffe/server.scm @@ -36,10 +36,11 @@ #:use-module (system repl error-handling) #:use-module (fibers) #:use-module (fibers channels) + #:use-module (knots web-server) #:use-module ((guix store) #:select (%store-prefix)) #:use-module (guix-data-service web util) #:use-module ((guix-build-coordinator utils fibers) - #:select (run-server/patched retry-on-error)) + #:select (retry-on-error)) #:use-module (bffe config) #:use-module (bffe view util) #:use-module (bffe view home) @@ -631,8 +632,10 @@ (sleep 1)) (simple-format #t "Starting the server\n") - (run-server/patched (lambda (request body) - (apply values - (handler request body controller))) - #:host host - #:port port)))) + (run-knots-web-server + (lambda (request) + (let ((body (read-request-body request))) + (apply values + (handler request body controller)))) + #:host host + #:port port)))) diff --git a/bffe/view/build.scm b/bffe/view/build.scm index c061668..1a7dc53 100644 --- a/bffe/view/build.scm +++ b/bffe/view/build.scm @@ -46,7 +46,23 @@ "success") "Succeeded" "Failed") - "Pending"))) + "Pending")) + ,@(or (and=> + (peek (assoc-ref build-details "result")) + (lambda (result) + `((ul + (li "Agent " + (a (@ (href ,(string-append + "/agent/" + (assoc-ref result "agent_id")))) + ,(assoc-ref result "agent_id"))) + ,@(or (and=> + (assoc-ref result "failure_reason") + (lambda (failure-reason) + `((li "Failure reason: ") + (dl ,failure-reason)))) + '()))))) + '())) (dt "Priority") (dd ,(assoc-ref build-details "priority"))) diff --git a/guix-dev.scm b/guix-dev.scm index 2fd1981..183c721 100644 --- a/guix-dev.scm +++ b/guix-dev.scm @@ -42,6 +42,38 @@ (gnu packages ruby) (srfi srfi-1)) +(define guile-knots + (let ((commit "e8ab6f23d8611c6ebb308007306a9ec5752cfbf0") + (revision "1")) + (package + (name "guile-knots") + (version (git-version "0" revision commit)) + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://git.cbaines.net/git/guile/knots") + (commit commit))) + (sha256 + (base32 + "1gbf6g0irjndvbycr3ygi6sh6y19v0h3h45460xgz46p62jiphsp")) + (file-name (string-append name "-" version "-checkout")))) + (build-system gnu-build-system) + (native-inputs + (list pkg-config + autoconf + automake + guile-3.0 + guile-fibers)) + (inputs + (list guile-3.0)) + (propagated-inputs + (list guile-fibers)) + (home-page "https://git.cbaines.net/guile/knots") + (synopsis "Patterns and functionality to use with Guile Fibers") + (description + "") + (license license:gpl3+)))) + (package (name "bffe") (version "0.0.0") @@ -52,6 +84,7 @@ guix-data-service guile-json-4 guile-fibers-1.3 + guile-knots guile-readline guile-prometheus guix-build-coordinator |