diff options
| -rw-r--r-- | bffe.scm | 50 | ||||
| -rw-r--r-- | bffe/config.scm.in | 1 | ||||
| -rw-r--r-- | bffe/manage-builds.scm | 260 | ||||
| -rw-r--r-- | bffe/server.scm | 27 | ||||
| -rw-r--r-- | bffe/view/activity.scm | 1 | ||||
| -rw-r--r-- | bffe/view/agent.scm | 4 | ||||
| -rw-r--r-- | bffe/view/build.scm | 22 | ||||
| -rw-r--r-- | bffe/view/home.scm | 4 | ||||
| -rw-r--r-- | bffe/view/util.scm | 8 | ||||
| -rw-r--r-- | guix-dev.scm | 33 |
10 files changed, 206 insertions, 204 deletions
@@ -17,6 +17,7 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (bffe) + #:use-module (srfi srfi-1) #:use-module (ice-9 format) #:use-module (oop goops) #:use-module (prometheus) @@ -26,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)) @@ -45,11 +45,14 @@ (port-log (make <port-log> #:port (current-output-port) #:formatter - (lambda (lvl time str) + ;; In guile-lib v0.2.8 onwards, the formatter is + ;; called with more arguments + (lambda args ; lvl, time, str (format #f "~a (~5a): ~a~%" - (strftime "%F %H:%M:%S" (localtime time)) - lvl - str))))) + (strftime "%F %H:%M:%S" (localtime + (second args))) + (first args) + (third args)))))) (setvbuf (current-output-port) 'line) @@ -57,20 +60,23 @@ (open-log! lgr) (set-default-logger! lgr) - (let ((finished? (make-condition))) - (call-with-sigint - (lambda () - (run-fibers - (lambda () - (for-each start-submit-builds-fibers - build) + (with-fluids ((%file-port-name-canonicalization 'none)) + (let ((finished? (make-condition))) + (call-with-sigint + (lambda () + (run-fibers + (lambda () + (for-each + (lambda (spec) + (start-submit-builds-fibers metrics-registry spec)) + build) - (when web-server-args - (apply start-bffe-web-server - `(,@web-server-args - #:pid-file ,pid-file - #:metrics-registry ,metrics-registry))) - (wait finished?)) - #:hz 0 - #:parallelism 1)) - finished?)))) + (when web-server-args + (apply start-bffe-web-server + `(,@web-server-args + #:pid-file ,pid-file + #:metrics-registry ,metrics-registry))) + (wait finished?)) + #:hz 0 + #:parallelism 1)) + finished?))))) diff --git a/bffe/config.scm.in b/bffe/config.scm.in index 19e5832..7af9d4d 100644 --- a/bffe/config.scm.in +++ b/bffe/config.scm.in @@ -17,7 +17,6 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (bffe config) - #:use-module (guix store) #:export (%config)) (define %config diff --git a/bffe/manage-builds.scm b/bffe/manage-builds.scm index 16484c3..9a4bd3e 100644 --- a/bffe/manage-builds.scm +++ b/bffe/manage-builds.scm @@ -21,20 +21,19 @@ #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) - #:use-module (rnrs bytevectors) #:use-module (ice-9 textual-ports) #:use-module (logging logger) - #:use-module (logging port-log) + #:use-module (prometheus) #:use-module (zlib) #: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 client) #:use-module (web response) #:use-module (guix-build-coordinator client-communication) - #:use-module ((guix-build-coordinator utils) #:select (create-work-queue)) #:use-module ((guix-build-coordinator utils fibers) #:select (retry-on-error)) #:use-module (bffe server) #:export (build-from-guix-data-service @@ -43,8 +42,9 @@ build-from-guix-data-service-systems build-from-guix-data-service-systems-and-targets build-from-guix-data-service-submit-builds-for-channel-instances? - build-from-guix-data-service-build-priority + 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)) @@ -60,14 +60,18 @@ (submit-builds-for-channel-instances? build-from-guix-data-service-submit-builds-for-channel-instances? (default #f)) - (build-priority build-from-guix-data-service-build-priority - (default #f)) + (build-keyword-arguments build-from-guix-data-service-build-keyword-arguments + (default #f)) (data-service-build-server-id build-from-guix-data-service-data-service-build-server-id (default #f)) (revision-parameters build-from-guix-data-service-revision-parameters - (default '()))) + (default '())) + (parallelism build-from-guix-data-service-parallelism + (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 @@ -78,7 +82,7 @@ (define* (guix-data-service-request guix-data-service path #:optional (query-parameters '()) - #:key (retry-times 0) (retry-delay 15)) + #:key (retry-times 3) (retry-delay 60)) (define uri (string->uri (string-append guix-data-service @@ -140,13 +144,18 @@ make-request #:times retry-times #:delay retry-delay - #:ignore (lambda (exn) - (and (guix-data-service-error? exn) - (< (guix-data-service-error-response-code exn) - 500)))))) + #:no-retry (lambda (exn) + (and (guix-data-service-error? exn) + (not + (= (guix-data-service-error-response-code exn) + 429)) + (< (guix-data-service-error-response-code exn) + 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 @@ -175,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" @@ -300,7 +246,7 @@ guix-data-service commit systems - priority-for-derivation + keyword-arguments-for-derivation #:key guix-data-service-build-server-id branch) @@ -337,26 +283,28 @@ (assoc-ref channel-instance-derivation "derivation")) (system (assoc-ref channel-instance-derivation "system"))) - (submit-build/fiberized - coordinator - guix-data-service - derivation - #:priority - (priority-for-derivation 'channel-instance - system - "none") - #:log-prefix - (simple-format #f "channel instance (~A): ~A: " - system - derivation) - #:tags `(((key . category) - (value . channel-instance)) - ((key . revision) - (value . ,commit)) - ,@(if branch - `(((key . branch) - (value . ,branch))) - '()))))) + (apply + submit-build/fiberized + (append! + (list + coordinator + guix-data-service + derivation + #:log-prefix + (simple-format #f "channel instance (~A): ~A: " + system + derivation) + #:tags `(((key . category) + (value . channel-instance)) + ((key . revision) + (value . ,commit)) + ,@(if branch + `(((key . branch) + (value . ,branch))) + '()))) + (keyword-arguments-for-derivation 'channel-instance + system + "none"))))) channel-instance-derivations-to-submit)))) (define* (submit-package-builds-for-revision @@ -366,7 +314,7 @@ commit system target - priority-for-derivation + keyword-arguments-for-derivation #:key guix-data-service-build-server-id branch) @@ -391,39 +339,48 @@ " package builds for " log-suffix) (fibers-for-each (lambda (derivation) - (submit-build/fiberized - coordinator - guix-data-service - derivation - #:priority - (priority-for-derivation 'package - system - target) - #:log-prefix - (if (string=? target "none") - (simple-format #f "package (~A): ~A: " - system derivation) - (simple-format #f "package (~A=>~A): ~A: " - system target derivation)) - #:tags `(((key . category) - (value . package)) - ((key . revision) - (value . ,commit)) - ,@(if branch - `(((key . branch) - (value . ,branch))) - '())))) + (apply + submit-build/fiberized + (append! + (list + coordinator + guix-data-service + derivation + #:log-prefix + (if (string=? target "none") + (simple-format #f "package (~A): ~A: " + system derivation) + (simple-format #f "package (~A=>~A): ~A: " + system target derivation)) + #:tags `(((key . category) + (value . package)) + ((key . revision) + (value . ,commit)) + ,@(if branch + `(((key . branch) + (value . ,branch))) + '()))) + (keyword-arguments-for-derivation 'package + system + target)))) unprocessed-package-derivations) (log-msg 'INFO "finished submitting " (length unprocessed-package-derivations) " package builds for " log-suffix)))) (define (submit-builds-pass + metrics-registry submit-build/fiberized guix-data-service specification processed-commits-hash record-revision-as-processed systems-and-targets) + (define unseen-revisions-metric + (or (metrics-registry-fetch-metric + metrics-registry "unseen_revisions_total") + (make-gauge-metric metrics-registry + "unseen_revisions_total"))) + (fibers-for-each (lambda (repository-id) (fibers-for-each @@ -440,17 +397,22 @@ (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)) (for-each (lambda (commit) (log-msg 'INFO "looking at revision " commit) @@ -464,7 +426,7 @@ guix-data-service commit (map car systems-and-targets) - (build-from-guix-data-service-build-priority + (build-from-guix-data-service-build-keyword-arguments specification) #:guix-data-service-build-server-id (build-from-guix-data-service-data-service-build-server-id @@ -483,7 +445,7 @@ commit system target - (build-from-guix-data-service-build-priority + (build-from-guix-data-service-build-keyword-arguments specification) #:guix-data-service-build-server-id (build-from-guix-data-service-data-service-build-server-id @@ -492,6 +454,7 @@ systems-and-targets) (log-msg 'INFO "finished looking at revision " commit) + (metric-decrement unseen-revisions-metric) (record-revision-as-processed commit)) (reverse unseen-revisions)))) (let ((all-branches (all-repository-branches guix-data-service @@ -505,9 +468,16 @@ (sleep 60)) -(define* (start-submit-builds-fibers specification +(define* (start-submit-builds-fibers metrics-registry + specification #:key processed-commits-file) + (define build-submitted-counter-metric + (or (metrics-registry-fetch-metric metrics-registry + "build_submitted_total") + (make-counter-metric metrics-registry + "build_submitted_total"))) + (define processed-commits-hash (make-hash-table)) @@ -519,9 +489,10 @@ (simple-format port "~A\n" commit) (close-port port)))) -(define* (submit-build coordinator guix-data-service derivation + (define* (submit-build coordinator guix-data-service derivation #:key (priority 0) (log-prefix "") - (tags '())) + (tags '()) + skip-updating-derived-priorities?) (retry-on-error (lambda () (let ((response @@ -534,13 +505,17 @@ #t #t #t - tags))) + tags + #:skip-updating-derived-priorities? + skip-updating-derived-priorities?))) (let ((no-build-submitted-response (assoc-ref response "no-build-submitted"))) (if no-build-submitted-response (log-msg 'DEBUG log-prefix "skipped: " no-build-submitted-response) - (log-msg 'DEBUG log-prefix "build submitted as " - (assoc-ref response "build-submitted")))))) + (begin + (metric-increment build-submitted-counter-metric) + (log-msg 'DEBUG log-prefix "build submitted as " + (assoc-ref response "build-submitted"))))))) ;; The TTL Guix uses for transient failures fetching substitutes is 10 ;; minutes, so we need to retry for longer than that #:times 30 @@ -572,8 +547,8 @@ (let ((submit-build/fiberized (fiberize submit-build - #:parallelism 8))) - + #:parallelism (build-from-guix-data-service-parallelism + specification)))) (spawn-fiber (lambda () (while #t @@ -587,7 +562,8 @@ (lambda () (with-throw-handler #t (lambda () - (submit-builds-pass submit-build/fiberized + (submit-builds-pass metrics-registry + submit-build/fiberized guix-data-service specification processed-commits-hash diff --git a/bffe/server.scm b/bffe/server.scm index dc9a06d..0c8c5d1 100644 --- a/bffe/server.scm +++ b/bffe/server.scm @@ -24,12 +24,9 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-71) #:use-module (ice-9 vlist) - #:use-module (ice-9 threads) #:use-module (ice-9 match) #:use-module (ice-9 atomic) #:use-module (ice-9 textual-ports) - #:use-module (rnrs bytevectors) - #:use-module (web http) #:use-module (web client) #:use-module (web request) #:use-module (web response) @@ -38,18 +35,12 @@ #:use-module (prometheus) #:use-module (system repl error-handling) #:use-module (fibers) - #:use-module (fibers scheduler) #:use-module (fibers channels) - #:use-module (fibers conditions) - #:use-module (fibers web server) + #:use-module (knots web-server) #:use-module ((guix store) #:select (%store-prefix)) - #:use-module ((guix build utils) #:select (dump-port)) #:use-module (guix-data-service web util) - #:use-module ((guix-build-coordinator utils) - #:select (with-time-logging call-with-delay-logging)) #:use-module ((guix-build-coordinator utils fibers) - #:select (run-server/patched retry-on-error)) - #:use-module (guix-build-coordinator client-communication) + #:select (retry-on-error)) #:use-module (bffe config) #:use-module (bffe view util) #:use-module (bffe view home) @@ -154,7 +145,7 @@ (lambda () (with-throw-handler #t (lambda () - (let ((response + (let ((_ body (http-get* (string->uri @@ -641,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/activity.scm b/bffe/view/activity.scm index 1621872..5a97bd2 100644 --- a/bffe/view/activity.scm +++ b/bffe/view/activity.scm @@ -2,7 +2,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (ice-9 match) - #:use-module (ice-9 format) #:use-module (bffe view util) #:use-module ((guix store) #:select (%store-prefix)) #:export (activity)) diff --git a/bffe/view/agent.scm b/bffe/view/agent.scm index e210402..1de2f71 100644 --- a/bffe/view/agent.scm +++ b/bffe/view/agent.scm @@ -1,10 +1,6 @@ (define-module (bffe view agent) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) - #:use-module (ice-9 match) - #:use-module (ice-9 format) #:use-module (bffe view util) - #:use-module ((guix store) #:select (%store-prefix)) #:export (agent)) (define (agent title agent-details) diff --git a/bffe/view/build.scm b/bffe/view/build.scm index ded00ef..1a7dc53 100644 --- a/bffe/view/build.scm +++ b/bffe/view/build.scm @@ -1,10 +1,6 @@ (define-module (bffe view build) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) - #:use-module (ice-9 match) - #:use-module (ice-9 format) #:use-module (bffe view util) - #:use-module ((guix store) #:select (%store-prefix)) #:export (build)) (define (build title build-details derivation-link-target tag-link-target) @@ -50,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/bffe/view/home.scm b/bffe/view/home.scm index 820f75f..3f3b1de 100644 --- a/bffe/view/home.scm +++ b/bffe/view/home.scm @@ -1,8 +1,4 @@ (define-module (bffe view home) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) - #:use-module (ice-9 match) - #:use-module (ice-9 format) #:use-module (bffe view util) #:export (home)) diff --git a/bffe/view/util.scm b/bffe/view/util.scm index 9b4a676..c6b89b0 100644 --- a/bffe/view/util.scm +++ b/bffe/view/util.scm @@ -17,23 +17,15 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (bffe view util) - #:use-module (guix-data-service config) - #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) - #:use-module (guix-data-service web html-utils) #:use-module ((guix-data-service web render) #:prefix guix-data-service:) #:use-module (ice-9 ftw) - #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) - #:use-module (web uri) #:use-module (web response) - #:use-module (texinfo) - #:use-module (texinfo html) - #:use-module (json) #:export (layout header form-horizontal-control 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 |