Add initial support for submitting builds

This provides similar functionality as provided by the
guix-build-coordinator-queue-builds-from-guix-data-service script, but I think
this is a better place for it.

Currently submitting builds isn't possible from the command line options, but
that could be supported in the future.

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)))))