diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | bffe.scm | 56 | ||||
| -rw-r--r-- | bffe/manage-builds.scm | 359 | ||||
| -rw-r--r-- | bffe/server.scm | 17 | ||||
| -rw-r--r-- | scripts/bffe.in | 24 |
5 files changed, 439 insertions, 19 deletions
diff --git a/Makefile.am b/Makefile.am index ff9fdad..72199b1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -28,8 +28,10 @@ godir = $(prefix)/lib/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache assetsdir = $(datadir)/@PACKAGE@ SOURCES = \ + bffe.scm \ bffe/config.scm \ bffe/server.scm \ + bffe/manage-builds.scm \ bffe/view/util.scm \ bffe/view/home.scm \ bffe/view/build.scm \ diff --git a/bffe.scm b/bffe.scm new file mode 100644 index 0000000..7f605d7 --- /dev/null +++ b/bffe.scm @@ -0,0 +1,56 @@ +;;; Build Farm Front-End +;;; +;;; Copyright © 2023 Christopher Baines <mail@cbaines.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program 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 +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (bffe) + #:use-module (ice-9 format) + #:use-module (oop goops) + #:use-module (prometheus) + #:use-module (logging logger) + #:use-module (logging port-log) + #:use-module (bffe server) + #:use-module (bffe manage-builds) + #:export (run-bffe-service)) + +(define* (run-bffe-service + #:key + (metrics-registry + (make-metrics-registry + #:namespace + "bffe")) + (build '()) + web-server-args) + (let ((lgr (make <logger>)) + (port-log (make <port-log> + #:port (current-output-port) + #:formatter + (lambda (lvl time str) + (format #f "~a (~5a): ~a~%" + (strftime "%F %H:%M:%S" (localtime time)) + lvl + str))))) + + (add-handler! lgr port-log) + (open-log! lgr) + (set-default-logger! lgr) + + (for-each start-submit-builds-thread + build) + + (apply start-bffe-web-server + `(,@web-server-args + #:metrics-registry ,metrics-registry)))) diff --git a/bffe/manage-builds.scm b/bffe/manage-builds.scm new file mode 100644 index 0000000..50cb13a --- /dev/null +++ b/bffe/manage-builds.scm @@ -0,0 +1,359 @@ +;;; Build Farm Front-End +;;; +;;; Copyright © 2023 Christopher Baines <mail@cbaines.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program 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 +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (bffe manage-builds) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:use-module (ice-9 threads) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 textual-ports) + #:use-module (logging logger) + #:use-module (logging port-log) + #:use-module (json) + #:use-module (guix records) + #:use-module (web uri) + #:use-module (web client) + #:use-module (guix-build-coordinator client-communication) + #:use-module ((guix-build-coordinator utils) #:select (create-work-queue + retry-on-error)) + #:export (build-from-guix-data-service + build-from-guix-data-service-data-service-url + build-from-guix-data-service-branches + 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-data-service-build-server-id + + start-submit-builds-thread)) + +(define-record-type* <build-from-guix-data-service> + build-from-guix-data-service make-build-from-guix-data-service + build-from-guix-data-service? + (data-service-url build-from-guix-data-service-data-service-url) + (build-coordinator-url build-from-guix-data-service-build-coordinator-url) + (branches build-from-guix-data-service-branches) + (systems build-from-guix-data-service-systems) + (systems-and-targets build-from-guix-data-service-systems-and-targets) + (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)) + (data-service-build-server-id + build-from-guix-data-service-data-service-build-server-id + (default #f))) + +(define* (guix-data-service-request guix-data-service + path + #:optional (query-parameters '())) + (define uri + (string->uri (string-append + guix-data-service + path + (if (null? query-parameters) + "" + (string-append + "?" + (string-join + (map (match-lambda + ((key . value) + (simple-format #f "~A=~A" key value))) + query-parameters) + "&")))))) + + (retry-on-error + (lambda () + (let ((response + body + (http-get uri))) + (json-string->scm (utf8->string body)))) + #:times 6 + #:delay (+ 15 (random 30)))) + +(define (all-repository-ids guix-data-service) + (let ((data (guix-data-service-request guix-data-service + "/repositories.json"))) + (map (lambda (entry) + (assoc-ref entry "id")) + (vector->list + (assoc-ref data "repositories"))))) + +(define (all-repository-branches guix-data-service repository-id) + (let ((data (guix-data-service-request guix-data-service + (string-append + "/repository/" + (number->string repository-id) + ".json")))) + (map (lambda (entry) + (assoc-ref entry "name")) + (vector->list + (assoc-ref data "branches"))))) + +(define (channel-instance-derivations-for-commit guix-data-service + commit + system) + (let ((data (guix-data-service-request + guix-data-service + (string-append "/revision/" commit "/channel-instances.json")))) + (filter-map (lambda (entry) + (if (string=? system + (assoc-ref entry "system")) + (assoc-ref entry "derivation") + #f)) + (vector->list + (assoc-ref data "channel_instances"))))) + +(define* (package-derivations-for-commit guix-data-service + commit + #:key system target + guix-data-service-build-server-id) + (let ((data (guix-data-service-request + guix-data-service + (string-append "/revision/" commit "/package-derivations.json") + `((system . ,system) + (target . ,target) + (field . "(no-additional-fields)") + ,@(if guix-data-service-build-server-id + `((no_build_from_build_server + . ,guix-data-service-build-server-id)) + '()) + (all_results . "on"))))) + (map (lambda (entry) + (assoc-ref entry "derivation")) + (vector->list + (assoc-ref data "derivations"))))) + +(define* (submit-build coordinator guix-data-service derivation + #:key (priority 0) (log-prefix "") + (tags '())) + (retry-on-error + (lambda () + (let ((response + (send-submit-build-request + coordinator + derivation + (list guix-data-service) + #f + priority + #t + #t + #t + tags))) + (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")))))) + ;; The TTL Guix uses for transient failures fetching substitutes is 10 + ;; minutes, so we need to retry for longer than that + #:times 30 + #:delay 30)) + +(define* (submit-builds-for-revision submit-build/async + coordinator + guix-data-service + commit + systems-and-targets + priority-for-derivation + #:key (submit-builds-for-channel-instances? + #t) + guix-data-service-build-server-id + branch) + (log-msg 'INFO "looking at revision " commit) + (par-for-each + (match-lambda + ((system . target) + (when (string=? target "none") + (when submit-builds-for-channel-instances? + (log-msg 'INFO "requesting channel instance derivations for " + system " (" commit ")") + (for-each (lambda (derivation) + (submit-build/async + coordinator + guix-data-service + derivation + #:priority + (priority-for-derivation 'channel-instance + system + target) + #: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))) + '())))) + (channel-instance-derivations-for-commit guix-data-service + commit + system)))) + + (let ((unprocessed-package-derivations + ;; Only request derivations in one thread at a time, just + ;; in cause doing this in parallel could lead to timeouts + (monitor + (log-msg 'INFO "requesting package derivations for " + system "=>" target " (" commit ")") + (package-derivations-for-commit guix-data-service + commit + #:system system + #:target target + #:guix-data-service-build-server-id + guix-data-service-build-server-id)))) + + (log-msg 'INFO "submitting package builds for " + system "=>" target " (" commit ")") + (for-each (lambda (derivation) + (submit-build coordinator + guix-data-service + derivation + #:priority + (priority-for-derivation 'package + system + target) + #:log-prefix + (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))) + '())))) + unprocessed-package-derivations)))) + systems-and-targets)) + +(define* (start-submit-builds-thread specification + #:key + processed-commits-file) + (define processed-commits-hash + (make-hash-table)) + + (define (record-revision-as-processed commit) + (when processed-commits-file + (monitor + (let ((port (open-file processed-commits-file "a"))) + (simple-format port "~A\n" commit) + (close-port port)) + + (hash-set! processed-commits-hash commit #t)))) + + (let* ((systems-and-targets + (append + (map (lambda (system) + (cons system "none")) + (build-from-guix-data-service-systems specification)) + (build-from-guix-data-service-systems-and-targets specification))) + (guix-data-service + (build-from-guix-data-service-data-service-url specification))) + + (when (and processed-commits-file + (file-exists? processed-commits-file)) + (call-with-input-file processed-commits-file + (lambda (port) + (let ((commits + (string-split (get-string-all port) #\newline))) + (for-each (lambda (commit) + (unless (string-null? commit) + (simple-format #t "marking ~A as already processed\n" + commit) + (hash-set! processed-commits-hash + commit + #t))) + commits))))) + + (let ((submit-build/async + count-jobs + count-threads + list-jobs + (create-work-queue 4 + submit-build + #:name "submit-builds"))) + (call-with-new-thread + (lambda () + (with-exception-handler + (lambda (exn) + (log-msg 'ERROR "exception in submit builds thread: " exn)) + (lambda () + (while #t + (for-each + (lambda (repository-id) + (for-each + (lambda (branch) + (let* ((branch-revisions + (guix-data-service-request guix-data-service + (string-append + "/repository/" + (number->string repository-id) + "/branch/" + branch + ".json"))) + (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"))))) + (for-each + (lambda (commit) + (submit-builds-for-revision + submit-build/async + (build-from-guix-data-service-build-coordinator-url + specification) + guix-data-service + commit + systems-and-targets + (build-from-guix-data-service-build-priority + specification) + #:submit-builds-for-channel-instances? + (build-from-guix-data-service-submit-builds-for-channel-instances? + specification) + #:guix-data-service-build-server-id + (build-from-guix-data-service-data-service-build-server-id + specification) + #:branch branch) + (record-revision-as-processed commit)) + unseen-revisions))) + (let ((all-branches (all-repository-branches guix-data-service + repository-id)) + (specified-branches + (build-from-guix-data-service-branches + specification))) + (or specified-branches + all-branches)))) + (all-repository-ids guix-data-service)) + + (while (not (= (count-jobs) 0)) + ;; Wait until all the builds have been submitted + (sleep 5)) + + (sleep 60))) + #:unwind? #t)))))) diff --git a/bffe/server.scm b/bffe/server.scm index 3df8e55..d130693 100644 --- a/bffe/server.scm +++ b/bffe/server.scm @@ -51,6 +51,7 @@ #:use-module ((guix-build-coordinator utils fibers) #:select (run-server/patched call-with-sigint)) #:use-module (guix-build-coordinator client-communication) + #:use-module (bffe config) #:use-module (bffe view util) #:use-module (bffe view home) #:use-module (bffe view build) @@ -347,8 +348,9 @@ (define* (make-controller assets-directory metrics-registry events-channel state-channel event-source + #:key title - template-directory) + (template-directory (%config 'template-dir))) (define handle-static-assets (if (string-prefix? (%store-prefix) @@ -527,10 +529,15 @@ (render-html #:sxml (error-page args) #:code 500)))) -(define* (start-bffe-web-server port host assets-directory - event-source - metrics-registry - #:key (controller-args '())) +(define* (start-bffe-web-server + #:key + (port 8767) + (host "0.0.0.0") + (assets-directory (%config 'assets-dir)) + (event-source "http://localhost:8746") + (controller-args '()) + metrics-registry) + (define state-channel (make-state-channel event-source)) diff --git a/scripts/bffe.in b/scripts/bffe.in index b85b2fe..8febcc9 100644 --- a/scripts/bffe.in +++ b/scripts/bffe.in @@ -31,7 +31,7 @@ (gcrypt pk-crypto) (guix pki) (prometheus) - (bffe server)) + (bffe)) (define %options ;; Specifications of the command-line options @@ -116,16 +116,12 @@ (assq-ref opts 'host) (assq-ref opts 'port)) - (let* ((metrics-registry (make-metrics-registry - #:namespace - "bffe"))) - - (start-bffe-web-server - (assq-ref opts 'port) - (assq-ref opts 'host) - (assq-ref opts 'assets-directory) - (assq-ref opts 'event-source) - metrics-registry - #:controller-args - (list (assq-ref opts 'title) - (assq-ref opts 'template-directory))))) + (run-bffe-service + #:web-server-args + (list #:port (assq-ref opts 'port) + #:host (assq-ref opts 'host) + #:assets-directory (assq-ref opts 'assets-directory) + #:events-source (assq-ref opts 'event-source) + #:controller-args + (list #:title (assq-ref opts 'title) + #:template-directory (assq-ref opts 'template-directory))))) |