Support adding tags to builds

1 files changed, 56 insertions, 3 deletions

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)