Support removing nar files

1 files changed, 130 insertions, 0 deletions

diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index a1670ed..5d2ad1f 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -40,6 +40,7 @@
             dump-database
 
             database-insert-narinfo
+            database-remove-narinfo
             database-select-narinfo-contents-by-hash
 
             database-select-recent-changes
@@ -516,6 +517,135 @@ INSERT INTO narinfo_tags (narinfo_id, tag_id) VALUES (:narinfo_id, :tag_id)"
 
        narinfo-id))))
 
+(define* (database-remove-narinfo database store-path
+                                  #:key change-datetime)
+  (define (store-path->narinfo-id db)
+    (let ((statement
+           (sqlite-prepare
+            db
+            "
+SELECT id FROM narinfos WHERE store_path = :store_path"
+            #:cache? #t)))
+
+      (sqlite-bind-arguments
+       statement
+       #:store_path store-path)
+
+      (let ((result (vector-ref (sqlite-step statement) 0)))
+        (sqlite-reset statement)
+
+        result)))
+
+  (define (remove-narinfo-record db id)
+    (let ((statement
+           (sqlite-prepare
+            db
+            "
+DELETE FROM narinfos WHERE id = :id"
+            #:cache? #t)))
+      (sqlite-bind-arguments
+       statement
+       #:id id)
+
+      (sqlite-step statement)
+      (sqlite-reset statement)))
+
+  (define (remove-narinfo-files db narinfo-id)
+    (let ((statement
+           (sqlite-prepare
+            db
+            "
+DELETE FROM narinfo_files WHERE narinfo_id = :narinfo_id"
+            #:cache? #t)))
+      (sqlite-bind-arguments
+       statement
+       #:narinfo_id narinfo-id)
+
+      (sqlite-map (const #t) statement)
+      (sqlite-reset statement)))
+
+  (define (remove-narinfo-references db narinfo-id)
+    (let ((statement
+           (sqlite-prepare
+            db
+            "
+DELETE FROM narinfo_references WHERE narinfo_id = :narinfo_id"
+            #:cache? #t)))
+      (sqlite-bind-arguments
+       statement
+       #:narinfo_id narinfo-id)
+
+      (sqlite-map (const #t) statement)
+      (sqlite-reset statement)))
+
+  (define (insert-change db contents)
+    (let ((statement
+           (sqlite-prepare
+            db
+            "
+INSERT INTO recent_changes (
+  datetime, change, data
+) VALUES (
+  datetime('now'), 'removal', :store_path
+)"
+            #:cache? #t)))
+      (sqlite-bind-arguments
+       statement
+       #:store_path store-path)
+
+      (sqlite-step statement)
+      (sqlite-reset statement)))
+
+  (define (insert-change-with-datetime db store-path datetime)
+    (let ((statement
+           (sqlite-prepare
+            db
+            "
+INSERT INTO recent_changes (
+  datetime, change, data
+) VALUES (
+  :datetime, 'removal', :store_path
+)"
+             #:cache? #t)))
+          (sqlite-bind-arguments
+           statement
+           #:store_path store-path
+           #:datetime datetime)
+
+          (sqlite-step statement)
+          (sqlite-reset statement)))
+
+  (define (remove-tags db narinfo-id)
+    (let ((statement
+           (sqlite-prepare
+            db
+            "
+DELETE FROM narinfo_tags WHERE narinfo_id = :narinfo_id"
+            #:cache? #t)))
+
+      (sqlite-bind-arguments
+       statement
+       #:narinfo_id narinfo-id)
+
+      (sqlite-map (const #t) statement)
+      (sqlite-reset statement)))
+
+  (database-call-with-transaction
+   database
+   (lambda (db)
+     (let ((narinfo-id (store-path->narinfo-id db)))
+       (if change-datetime
+           (insert-change-with-datetime db store-path
+                                        change-datetime)
+           (insert-change db store-path))
+
+       (remove-narinfo-files db narinfo-id)
+       (remove-narinfo-references db narinfo-id)
+       (remove-tags db narinfo-id)
+       (remove-narinfo-record db narinfo-id)
+
+       #t))))
+
 (define (database-select-narinfo-contents-by-hash database hash)
   (call-with-worker-thread
    (database-reader-thread-channel database)