Support inserting tags when inserting narinfos

This is the beginning of implementing support for tagging.

The communicating of tags through changes still needs implementing.

2 files changed, 85 insertions, 4 deletions

diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index e8c8b8d..a1670ed 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -324,8 +324,48 @@ PRAGMA optimize;")))
 
       id)))
 
+(define (tag->tag-id db key value)
+  (define (insert-tag)
+    (let ((statement
+           (sqlite-prepare
+            db
+            "
+INSERT INTO tags (key, value) VALUES (:key, :value)"
+            #:cache? #t)))
+
+      (sqlite-bind-arguments
+       statement
+       #:key key
+       #:value value)
+
+      (sqlite-step statement)
+      (sqlite-reset statement)
+
+      (last-insert-rowid db)))
+
+  (let ((statement
+         (sqlite-prepare
+          db
+          "
+SELECT id FROM tags WHERE key = :key AND value = :value"
+          #:cache? #t)))
+
+    (sqlite-bind-arguments
+     statement
+     #:key key
+     #:value value)
+
+    (match (let ((result (sqlite-step statement)))
+             (sqlite-reset statement)
+             result)
+      (#f
+       (insert-tag))
+      (#(id)
+       id))))
+
 (define* (database-insert-narinfo database narinfo
-                                  #:key change-datetime)
+                                  #:key change-datetime
+                                  (tags '()))
   (define (insert-narinfo-record db)
     (let ((statement
            (sqlite-prepare
@@ -428,6 +468,26 @@ INSERT INTO recent_changes (
           (sqlite-step statement)
           (sqlite-reset statement)))
 
+  (define (insert-tags db narinfo-id tags)
+    (let ((statement
+           (sqlite-prepare
+            db
+            "
+INSERT INTO narinfo_tags (narinfo_id, tag_id) VALUES (:narinfo_id, :tag_id)"
+            #:cache? #t)))
+
+      (map (match-lambda
+             ((key . value)
+              (let ((tag-id (tag->tag-id db key value)))
+                (sqlite-bind-arguments
+                 statement
+                 #:narinfo_id narinfo-id
+                 #:tag_id tag-id)
+
+                (sqlite-step statement)
+                (sqlite-reset statement))))
+           tags)))
+
   (database-call-with-transaction
    database
    (lambda (db)
@@ -451,6 +511,9 @@ INSERT INTO recent_changes (
                                         change-datetime)
            (insert-change db (narinfo-contents narinfo)))
 
+       (unless (null? tags)
+         (insert-tags db narinfo-id tags))
+
        narinfo-id))))
 
 (define (database-select-narinfo-contents-by-hash database hash)
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index 1cc5a67..0f4f7f2 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -77,6 +77,20 @@
   `((database . ,(string-append (getcwd) "/nar_herder.db"))
     (database-dump . ,(string-append (getcwd) "/nar_herder_dump.db"))))
 
+(define %import-options
+  (list (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 %import-options-defaults
+  '())
+
 (define %server-options
   (list (option '("port") #t #f
                 (lambda (opt name arg result)
@@ -172,8 +186,10 @@
 
 (match (cdr (program-arguments))
   (("import" rest ...)
-   (let* ((opts (parse-options %base-options
-                               %base-option-defaults
+   (let* ((opts (parse-options (append %base-options
+                                       %import-options)
+                               (append %base-option-defaults
+                                       %import-options-defaults)
                                rest))
           (database (setup-database
                      (assq-ref opts 'database))))
@@ -212,7 +228,9 @@
                           (lambda (port)
                             ;; Set url to a dummy value as this doesn't
                             ;; matter
-                            (read-narinfo port "https://narherderdummyvalue"))))
+                            (read-narinfo port "https://narherderdummyvalue")))
+                        #:tags (or (assq-ref opts 'tags)
+                                   '()))
 
                        (report))
                      narinfos))))))