Support adding tags to builds

11 files changed, 146 insertions, 11 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 86f75d8..1347da5 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -193,6 +193,14 @@
                    ,@(if (assoc-ref
                           body "ensure-all-related-derivation-outputs-have-builds")
                          '(#:ensure-all-related-derivation-outputs-have-builds? #t)
+                         '())
+                   ,@(if (assoc-ref body "tags")
+                         `(#:tags
+                           ,(map
+                             (lambda (tag)
+                               (cons (assoc-ref tag "key")
+                                     (assoc-ref tag "value")))
+                             (vector->list (assoc-ref body "tags"))))
                          '())))))
            (render-json submit-build-result))))
       (_
@@ -270,7 +278,8 @@
          priority
          ignore-if-build-for-derivation-exists?
          ignore-if-build-for-outputs-exists?
-         ensure-all-related-derivation-outputs-have-builds?)
+         ensure-all-related-derivation-outputs-have-builds?
+         tags)
   (send-request coordinator-uri
                 'POST
                 "/builds"
@@ -287,7 +296,15 @@
                         '())
                   ,@(if ensure-all-related-derivation-outputs-have-builds?
                         '((ensure-all-related-derivation-outputs-have-builds . #t))
-                        '()))))
+                        '())
+                  ,@(if (null? tags)
+                        '()
+                        `((tags . ,(list->vector
+                                    (map (match-lambda
+                                           ((key . value)
+                                            `((key   . ,key)
+                                              (value . ,value))))
+                                         tags))))))))
 
 (define (request-build-details coordinator-uri
                                uuid)
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index a143661..7c3201c 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -87,7 +87,8 @@
                        (priority 0)
                        (ignore-if-build-for-derivation-exists? #f)
                        (ignore-if-build-for-outputs-exists? #f)
-                       (ensure-all-related-derivation-outputs-have-builds? #f))
+                       (ensure-all-related-derivation-outputs-have-builds? #f)
+                       (tags '()))
   (define datastore (build-coordinator-datastore build-coordinator))
 
   (define (build-for-derivation-exists?)
@@ -132,13 +133,15 @@
                                             related-uuid
                                             ;; Let the scheduler take care of
                                             ;; the prioritisation
-                                            0)))
+                                            0
+                                            '())))
                  derivations-lacking-builds)))
 
             (datastore-store-build datastore
                                    derivation-file
                                    uuid
-                                   priority)
+                                   priority
+                                   tags)
 
             (trigger-build-allocation build-coordinator)
 
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 1b9e044..c0798e9 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -388,7 +388,53 @@ INNER JOIN related_derivations
                 (datastore <sqlite-datastore>)
                 derivation-name
                 uuid
-                priority)
+                priority
+                tags)
+  (define (insert-tags db build-id tags)
+    (let ((insert-tag-statement
+           (sqlite-prepare
+            db
+            "
+INSERT INTO tags (\"key\", \"value\") VALUES (:tagkey, :tagvalue)"
+            #:cache? #t))
+          (find-tag-statement
+           (sqlite-prepare
+            db
+            "
+SELECT id FROM tags WHERE key = :tag_key AND value = :tag_value"
+            #:cache? #t))
+          (build-tags-statement
+           (sqlite-prepare
+            db
+            "
+INSERT INTO build_tags (build_id, tag_id) VALUES (:build_id, :tag_id)"
+            #:cache? #t)))
+
+      (define (tag->id key value)
+        (sqlite-reset find-tag-statement)
+        (sqlite-bind-arguments find-tag-statement
+                               #:tag_key key
+                               #:tag_value value)
+        (match (sqlite-step find-tag-statement)
+          (#(id) id)
+          (#f
+           (sqlite-reset insert-tag-statement)
+           (sqlite-bind-arguments insert-tag-statement
+                                  #:tagkey key
+                                  #:tagvalue value)
+           (sqlite-step insert-tag-statement)
+           (last-insert-rowid db))))
+
+      (for-each
+       (match-lambda
+         ((key . value)
+          (sqlite-reset build-tags-statement)
+          (sqlite-bind-arguments build-tags-statement
+                                 #:build_id build-id
+                                 #:tag_id (tag->id key value))
+          (sqlite-step build-tags-statement)))
+       tags)))
+
   (call-with-worker-thread
    (slot-ref datastore 'worker-writer-thread-channel)
    (lambda (db)
@@ -401,8 +447,15 @@ INNER JOIN related_derivations
            (sqlite-exec db "ROLLBACK TRANSACTION;")
            (raise-exception exn))
        (lambda ()
-         (insert-build db uuid derivation-name priority)
-         (sqlite-exec db "COMMIT TRANSACTION;"))
+         (with-exception-handler
+             (lambda (exn)
+               (backtrace)
+               (raise-exception exn))
+           (lambda ()
+             (insert-build db uuid derivation-name priority)
+             (unless (null? tags)
+               (insert-tags db uuid tags))
+             (sqlite-exec db "COMMIT TRANSACTION;"))))
        #:unwind? #t)))
   #t)
 
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index a0563e8..01752bd 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -103,13 +103,22 @@
                 (lambda (opt name arg result)
                   (alist-cons 'derivation-substitute-urls
                               (string-split arg #\space)
-                              result)))))
+                              result)))
+        (option '("tag") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'tags
+                              (cons (match (string-split arg #\=)
+                                      ((key value) (cons key value)))
+                                    (or (assq-ref result 'tags)
+                                        '()))
+                              (alist-delete 'tags result))))))
 
 (define %build-option-defaults
   `((priority                                          . 0)
     (ignore-if-build-for-derivation-exists             . #f)
     (ignore-if-build-for-outputs-exists                . #f)
-    (ensure-all-related-derivation-outputs-have-builds . #f)))
+    (ensure-all-related-derivation-outputs-have-builds . #f)
+    (tags                                              . ())))
 
 (define %service-options
   (list (option '("pid-file") #t #f
@@ -344,7 +353,8 @@ processed?:      ~A
                 (assq-ref opts 'ignore-if-build-for-derivation-exists)
                 (assq-ref opts 'ignore-if-build-for-outputs-exists)
                 (assq-ref opts
-                          'ensure-all-related-derivation-outputs-have-builds))))
+                          'ensure-all-related-derivation-outputs-have-builds)
+                (assq-ref opts 'tags))))
           (let ((no-build-submitted-response
                  (assoc-ref response "no-build-submitted")))
             (if no-build-submitted-response
diff --git a/sqitch/pg/deploy/build_tags.sql b/sqitch/pg/deploy/build_tags.sql
new file mode 100644
index 0000000..211b7c5
--- /dev/null
+++ b/sqitch/pg/deploy/build_tags.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-build-coordinator:build_tags to pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/revert/build_tags.sql b/sqitch/pg/revert/build_tags.sql
new file mode 100644
index 0000000..938221f
--- /dev/null
+++ b/sqitch/pg/revert/build_tags.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:build_tags from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/verify/build_tags.sql b/sqitch/pg/verify/build_tags.sql
new file mode 100644
index 0000000..d314341
--- /dev/null
+++ b/sqitch/pg/verify/build_tags.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:build_tags on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index 0946279..1aa3b80 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -15,3 +15,4 @@ unprocessed_hook_events 2020-05-08T12:55:28Z Christopher Baines <mail@cbaines.ne
 derivation_outputs_derivation_name_index 2020-05-10T16:24:05Z Christopher Baines <mail@cbaines.net> # Add an index on derivation_outputs.derivation_name
 build_results_result_index 2020-05-10T17:27:00Z Christopher Baines <mail@cbaines.net> # Add an index on build_results.result
 more_indexes_on_builds_and_derivation_inputs 2020-05-11T08:38:28Z Christopher Baines <mail@cbaines.net> # Add a couple more indexes
+build_tags 2020-05-31T13:54:41Z Christopher Baines <mail@cbaines.net> # Support tagging builds
diff --git a/sqitch/sqlite/deploy/build_tags.sql b/sqitch/sqlite/deploy/build_tags.sql
new file mode 100644
index 0000000..7f2c040
--- /dev/null
+++ b/sqitch/sqlite/deploy/build_tags.sql
@@ -0,0 +1,16 @@
+-- Deploy guix-build-coordinator:build_tags to sqlite
+
+BEGIN;
+
+CREATE TABLE tags (
+       id INTEGER PRIMARY KEY ASC,
+       key TEXT NOT NULL,
+       value TEXT NOT NULL
+);
+
+CREATE TABLE build_tags (
+       build_id TEXT NOT NULL REFERENCES builds (uuid),
+       tag_id INTEGER NOT NULL REFERENCES tags (id)
+);
+
+COMMIT;
diff --git a/sqitch/sqlite/revert/build_tags.sql b/sqitch/sqlite/revert/build_tags.sql
new file mode 100644
index 0000000..f6bcef8
--- /dev/null
+++ b/sqitch/sqlite/revert/build_tags.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:build_tags from sqlite
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/sqlite/verify/build_tags.sql b/sqitch/sqlite/verify/build_tags.sql
new file mode 100644
index 0000000..5cd681b
--- /dev/null
+++ b/sqitch/sqlite/verify/build_tags.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:build_tags on sqlite
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;