From dbadb56b19b76d62d0dddfdea1f1676b0366b729 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 28 Jun 2020 13:13:21 +0100
Subject: Add a hook for when a build starts on an agent

---
 guix-build-coordinator/datastore/sqlite.scm | 16 +++++++++++++---
 guix-build-coordinator/hooks.scm            |  6 ++++++
 scripts/guix-build-coordinator.in           |  7 +++++++
 3 files changed, 26 insertions(+), 3 deletions(-)

diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 4251f75..5ed70ac 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -612,8 +612,14 @@ VALUES "
                 build-id
                 agent-id)
 
-  (call-with-worker-thread
-   (slot-ref datastore 'worker-writer-thread-channel)
+  (define (handle-inserting-unprocessed-hook-event db build-id agent-id)
+    (insert-unprocessed-hook-event
+     db
+     "build-started"
+     (list build-id agent-id)))
+
+  (datastore-call-with-transaction
+   datastore
    (lambda (db)
      (sqlite-exec
       db
@@ -625,7 +631,11 @@ INSERT INTO build_starts (
        build-id "', '"
        agent-id "', "
        "datetime('now')"
-       ")")))))
+       ")"))
+
+     (handle-inserting-unprocessed-hook-event db build-id agent-id)))
+
+  #t)
 
 (define-method (datastore-find-build-starts
                 (datastore <sqlite-datastore>)
diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm
index 0491df6..2def72c 100644
--- a/guix-build-coordinator/hooks.scm
+++ b/guix-build-coordinator/hooks.scm
@@ -30,6 +30,7 @@
   #:use-module (guix-build-coordinator datastore)
   #:use-module (guix-build-coordinator coordinator)
   #:export (default-build-submitted-hook
+            default-build-started-hook
             default-build-success-hook
             build-success-publish-hook
             build-success-s3-publish-hook
@@ -42,6 +43,11 @@
    (simple-format #f "build ~A submtited\n" build-id)
    (current-error-port)))
 
+(define (default-build-started-hook build-coordinator build-id agent-id)
+  (display
+   (simple-format #f "build ~A started on agent ~A\n" build-id agent-id)
+   (current-error-port)))
+
 (define (default-build-success-hook build-coordinator build-id)
   (define datastore
     (build-coordinator-datastore build-coordinator))
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 8163280..1d2781e 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -157,6 +157,11 @@
                   (alist-cons 'build-submitted-hook
                               (read/eval arg)
                               (alist-delete 'build-submitted-hook result))))
+        (option '("build-started-hook") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-started-hook
+                              (read/eval arg)
+                              (alist-delete 'build-started-hook result))))
         (option '("build-success-hook") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'build-success-hook
@@ -179,6 +184,7 @@
     (client-communication                 . "http://127.0.0.1:8746")
     (allocation-strategy                  . ,basic-build-allocation-strategy)
     (build-submitted-hook                 . ,default-build-submitted-hook)
+    (build-started-hook                   . ,default-build-started-hook)
     (build-success-hook                   . ,default-build-success-hook)
     (build-failure-hook                   . ,default-build-failure-hook)
     (build-missing-inputs-hook            . ,default-build-missing-inputs-hook)))
@@ -434,6 +440,7 @@ processed?:      ~A
                       #:metrics-registry metrics-registry))
           (hooks
            `((build-submitted      . ,(assq-ref opts 'build-submitted-hook))
+             (build-started        . ,(assq-ref opts 'build-started-hook))
              (build-success        . ,(assq-ref opts 'build-success-hook))
              (build-failure        . ,(assq-ref opts 'build-failure-hook))
              (build-missing-inputs . ,(assq-ref opts 'build-missing-inputs-hook))))
-- 
cgit v1.2.3