Implement a couple of basic hooks

This allows configurable code to be executed when builds succeed or fail.

4 files changed, 116 insertions, 10 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 23c119c..9aa7f55 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -71,10 +71,13 @@ if there was no request body."
              fixed/read-request-body)
 
 (define (http-agent-messaging-start-server port host secret-key-base
-                                           datastore)
+                                           datastore hooks)
   (define build-allocator-channel
     (make-build-allocator-channel datastore))
 
+  (define hook-channel
+    (make-hook-channel datastore hooks))
+
   (define (trigger-build-allocation)
     (put-message build-allocator-channel #t))
 
@@ -94,7 +97,8 @@ if there was no request body."
                            body
                            secret-key-base
                            datastore
-                           trigger-build-allocation)))
+                           trigger-build-allocation
+                           hook-channel)))
       'http
       (list #:host host
             #:port port)))
@@ -131,7 +135,8 @@ port. Also, the port used can be changed by passing the --port option.\n"
                     body
                     secret-key-base
                     datastore
-                    trigger-build-allocation)
+                    trigger-build-allocation
+                    hook-channel)
   (define (authenticated? uuid request)
     (let* ((authorization-base64
             (match (assq-ref (request-headers request)
@@ -183,7 +188,8 @@ port. Also, the port used can be changed by passing the --port option.\n"
               (datastore-agent-for-build datastore uuid)))
          (if (authenticated? agent-id-for-build request)
              (begin
-               (handle-build-result datastore agent-id-for-build uuid
+               (handle-build-result datastore hook-channel
+                                    agent-id-for-build uuid
                                     (json-string->scm (utf8->string body)))
                ;; Trigger build allocation, as the result of this build could
                ;; change the allocation
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index ece04a3..c0e7cb1 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -35,6 +35,7 @@
             fetch-builds
             agent-details
             make-build-allocator-channel
+            make-hook-channel
 
             build-output-file-location
             handle-build-result
@@ -100,6 +101,37 @@
 
     channel))
 
+(define (make-hook-channel datastore hooks)
+  (let ((channel (make-channel)))
+    (call-with-new-thread
+     (lambda ()
+       (let loop ((message (get-message channel)))
+         (match message
+           (('build-success build-id)
+            (catch
+              #t
+              (lambda ()
+                ((assq-ref hooks 'build-success) datastore build-id))
+              (lambda (key . args)
+                (simple-format #t "error: running build-success hook: ~A ~A\n"
+                               key args)
+                #f)))
+           (('build-failure build-id)
+            (catch
+              #t
+              (lambda ()
+                ((assq-ref hooks 'build-failure) datastore build-id))
+              (lambda (key . args)
+                (simple-format #t "error: running build-failure hook: ~A ~A\n"
+                               key args)
+                #f)))
+           (unknown
+            (simple-format #t "error: hooks: unknown message: ~A\n"
+                           unknown)))
+         (loop (get-message channel)))))
+
+    channel))
+
 (define (fetch-builds datastore agent)
   (let ((builds (datastore-list-allocation-plan-builds
                  datastore
@@ -128,7 +160,8 @@
                    (basename output)
                    ".nar.lz")))
 
-(define (handle-build-result datastore agent-id build-id result-json)
+(define (handle-build-result datastore hook-channel
+                             agent-id build-id result-json)
   (let ((result (assoc-ref result-json "result")))
     (datastore-store-build-result datastore
                                   build-id
@@ -136,7 +169,14 @@
                                   (if (string=? result "success")
                                       "success"
                                       "failure")
-                                  #f))) ; TODO
+                                  #f) ;; TODO
+
+    (put-message hook-channel
+                 (list (if (string=? result "success")
+                           'build-success
+                           'build-failure)
+                       build-id))))
+
 
 (define (handle-setup-failure-report datastore agent-id build-id report-json)
   (let ((failure-reason (assoc-ref report-json "failure_reason")))
diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm
new file mode 100644
index 0000000..ed0b890
--- /dev/null
+++ b/guix-build-coordinator/hooks.scm
@@ -0,0 +1,42 @@
+;;; Guix Build Coordinator
+;;;
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of the guix-build-coordinator.
+;;;
+;;; The Guix Build Coordinator is free software; you can redistribute
+;;; it and/or modify it under the terms of the GNU General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; The Guix Build Coordinator 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-build-coordinator hooks)
+  #:use-module (guix-build-coordinator datastore)
+  #:export (default-build-success-hook
+            default-build-failure-hook))
+
+(define (default-build-success-hook datastore build-id)
+  (let ((agent-id
+         (datastore-agent-for-build datastore build-id)))
+    (display
+     (simple-format #f
+                    "build ~A succeeded (on agent ~A)\n"
+                    build-id agent-id)
+     (current-error-port))))
+
+(define* (default-build-failure-hook datastore build-id)
+  (let ((agent-id
+         (datastore-agent-for-build datastore build-id)))
+    (display
+     (simple-format #f
+                    "build ~A failed (on agent ~A)\n"
+                    build-id agent-id)
+     (current-error-port))))
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index bfc17d4..458b693 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -25,6 +25,8 @@
 (use-modules (srfi srfi-1)
              (srfi srfi-37)
              (ice-9 match)
+             ((guix ui) #:select (read/eval))
+             (guix-build-coordinator hooks)
              (guix-build-coordinator config)
              (guix-build-coordinator datastore)
              (guix-build-coordinator coordinator)
@@ -77,12 +79,24 @@
                 (lambda (opt name arg result)
                   (alist-cons 'host
                               arg
-                              (alist-delete 'host result))))))
+                              (alist-delete 'host result))))
+        (option '("build-success-hook") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-success-hook
+                              (read/eval arg)
+                              (alist-delete 'build-success-hook result))))
+        (option '("build-failure-hook") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'build-failure-hook
+                              (read/eval arg)
+                              (alist-delete 'build-failure-hook result))))))
 
 (define %service-option-defaults
   ;; Alist of default option values
   `((port                                 . 8745)
-    (host                                 . "0.0.0.0")))
+    (host                                 . "0.0.0.0")
+    (build-success-hook                   . ,default-build-success-hook)
+    (build-failure-hook                   . ,default-build-failure-hook)))
 
 (define %agent-options
   (list (option '("uuid") #t #f
@@ -162,7 +176,10 @@
                                        %base-option-defaults)
                                arguments))
           (datastore (database-uri->datastore
-                      (assq-ref opts 'database))))
+                      (assq-ref opts 'database)))
+          (hooks
+           `((build-success . ,(assq-ref opts 'build-success-hook))
+             (build-failure . ,(assq-ref opts 'build-failure-hook)))))
 
      (when (assoc-ref opts 'update-database)
        (datastore-update datastore))
@@ -183,4 +200,5 @@
         (assq-ref opts 'port)
         (assq-ref opts 'host)
         (assq-ref opts 'secret-key-base)
-        datastore)))))
+        datastore
+        hooks)))))