Rework the cached compressions system

The initial implementation was flawed since guix assumes that any
compression mentioned in the narinfo will be available for the
lifetime of the narinfo, and the nar-herder was deleting cached
compressions without taking this in to account.

This commit adds support for scheduling the removal of a cached
compression and this schedule is used to inform the TTLs for narinfos.

I'm unsure of the value in caching narinfos so maybe some of this
complexity can be removed in the future.

1 files changed, 277 insertions, 10 deletions

diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index c8171a3..98c29d5 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -43,6 +43,7 @@
 
             database-insert-narinfo
             database-remove-narinfo
+            database-select-narinfo
             database-select-narinfo-by-hash
             database-select-narinfo-contents-by-hash
 
@@ -64,7 +65,13 @@
             database-select-cached-narinfo-file-by-hash
             database-select-cached-narinfo-files-by-narinfo-id
             database-fold-cached-narinfo-files
-            database-remove-cached-narinfo-file))
+            database-remove-cached-narinfo-file
+
+            database-select-scheduled-narinfo-removal
+            database-select-scheduled-cached-narinfo-removal
+            database-delete-scheduled-cached-narinfo-removal
+            database-select-oldest-scheduled-cached-narinfo-removal
+            database-insert-scheduled-cached-narinfo-removal))
 
 (define-record-type <database>
   (make-database database-file reader-thread-channel writer-thread-channel
@@ -145,7 +152,17 @@ CREATE TABLE cached_narinfo_files (
 );
 
 CREATE INDEX cached_narinfo_files_narinfo_id
-  ON cached_narinfo_files (narinfo_id);")
+  ON cached_narinfo_files (narinfo_id);
+
+CREATE TABLE scheduled_narinfo_removal (
+  narinfo_id INTEGER PRIMARY KEY ASC REFERENCES narinfos (id),
+  removal_datetime TEXT NOT NULL
+);
+
+CREATE TABLE scheduled_cached_narinfo_removal (
+  cached_narinfo_file_id INTEGER PRIMARY KEY ASC REFERENCES cached_narinfo_files (id),
+  removal_datetime TEXT NOT NULL
+);")
 
   (sqlite-exec db schema))
 
@@ -206,6 +223,24 @@ CREATE INDEX cached_narinfo_files_narinfo_id
      db
      "ALTER TABLE narinfos ADD COLUMN added_at TEXT;"))
 
+  (unless (table-exists? db "scheduled_narinfo_removal")
+    (sqlite-exec
+     db
+     "
+CREATE TABLE scheduled_narinfo_removal (
+  narinfo_id INTEGER PRIMARY KEY ASC REFERENCES narinfos (id),
+  removal_datetime TEXT NOT NULL
+);"))
+
+  (unless (table-exists? db "scheduled_cached_narinfo_removal")
+    (sqlite-exec
+     db
+     "
+CREATE TABLE scheduled_cached_narinfo_removal (
+  cached_narinfo_file_id INTEGER PRIMARY KEY ASC REFERENCES cached_narinfo_files (id),
+  removal_datetime TEXT NOT NULL
+);"))
+
   (sqlite-exec
    db
    "CREATE INDEX IF NOT EXISTS narinfo_tags_narinfo_id
@@ -835,6 +870,38 @@ DELETE FROM narinfo_tags WHERE narinfo_id = :narinfo_id"
              #t)
            #f)))))
 
+(define (database-select-narinfo database id)
+  (call-with-time-tracking
+   database
+   "select_narinfo"
+   (lambda ()
+     (call-with-worker-thread
+      (database-reader-thread-channel database)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                "
+SELECT store_path, nar_hash, nar_size, deriver, system
+FROM narinfos
+WHERE id = :id"
+                #:cache? #t)))
+          (sqlite-bind-arguments
+           statement
+           #:id id)
+
+          (match (let ((result (sqlite-step statement)))
+                   (sqlite-reset statement)
+                   result)
+            (#(store_path nar_hash nar_size deriver system)
+             `((store-path . ,store_path)
+               (nar-hash   . ,nar_hash)
+               (nar-size   . ,nar_size)
+               (deriver    . ,deriver)
+               (system     . ,system)))
+            (_
+             #f))))))))
+
 (define (database-select-narinfo-by-hash database hash)
   (call-with-time-tracking
    database
@@ -1175,7 +1242,7 @@ INSERT INTO cached_narinfo_files (
         statement
         #:narinfo_id narinfo-id
         #:size size
-        #:compression compression)
+        #:compression (symbol->string compression))
 
        (sqlite-step statement)
        (sqlite-reset statement)
@@ -1196,7 +1263,7 @@ INSERT INTO cached_narinfo_files (
                (sqlite-prepare
                 db
                 "
-SELECT cached_narinfo_files.size
+SELECT cached_narinfo_files.id, cached_narinfo_files.size
 FROM narinfos
 INNER JOIN cached_narinfo_files
   ON cached_narinfo_files.narinfo_id = narinfos.id
@@ -1207,12 +1274,13 @@ WHERE substr(narinfos.store_path, 12, 32) = :hash
           (sqlite-bind-arguments
            statement
            #:hash hash
-           #:compression compression)
+           #:compression (symbol->string compression))
 
           (let ((result
                  (match (sqlite-step statement)
-                   (#(size)
-                    `((size . ,size)))
+                   (#(id size)
+                    `((id   . ,id)
+                      (size . ,size)))
                    (#f #f))))
             (sqlite-reset statement)
 
@@ -1232,7 +1300,10 @@ WHERE substr(narinfos.store_path, 12, 32) = :hash
                (sqlite-prepare
                 db
                 "
-SELECT store_path, size, compression
+SELECT cached_narinfo_files.id,
+       narinfos.store_path,
+       cached_narinfo_files.size,
+       cached_narinfo_files.compression
 FROM cached_narinfo_files
 INNER JOIN narinfos
   ON cached_narinfo_files.narinfo_id = narinfos.id
@@ -1246,8 +1317,9 @@ WHERE narinfo_id = :narinfo_id"
           (let ((result
                  (sqlite-map
                   (match-lambda
-                    (#(store_path size compression)
-                     `((store-path  . ,store_path)
+                    (#(id store_path size compression)
+                     `((id          . ,id)
+                       (store-path  . ,store_path)
                        (size        . ,size)
                        (compression . ,(string->symbol compression)))))
                   statement)))
@@ -1255,6 +1327,48 @@ WHERE narinfo_id = :narinfo_id"
 
             result)))))))
 
+(define (database-select-cached-narinfo-file-by-narinfo-id-and-compression
+         database
+         narinfo-id
+         compression)
+  (call-with-time-tracking
+   database
+   "select_cached_narinfo_file_by_narinfo_id_and_compression"
+   (lambda ()
+     (call-with-worker-thread
+      (database-reader-thread-channel database)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                "
+SELECT cached_narinfo_files.id,
+       narinfos.store_path,
+       cached_narinfo_files.size,
+       cached_narinfo_files.compression
+FROM cached_narinfo_files
+INNER JOIN narinfos
+  ON cached_narinfo_files.narinfo_id = narinfos.id
+WHERE narinfo_id = :narinfo_id
+  AND compression = :compression"
+                #:cache? #t)))
+
+          (sqlite-bind-arguments
+           statement
+           #:narinfo_id narinfo-id
+           #:compression (symbol->string compression))
+
+          (let ((result
+                 (match (sqlite-step statement)
+                   (#(id store_path size compression)
+                    `((id          . ,id)
+                      (store-path  . ,store_path)
+                      (size        . ,size)
+                      (compression . ,(string->symbol compression)))))))
+            (sqlite-reset statement)
+
+            result)))))))
+
 (define (database-fold-cached-narinfo-files database
                                             proc
                                             init)
@@ -1306,3 +1420,156 @@ WHERE narinfo_id = :narinfo_id
 
        (sqlite-step statement)
        (sqlite-reset statement)))))
+
+(define (database-select-scheduled-narinfo-removal database narinfo-id)
+  (call-with-time-tracking
+   database
+   "select_scheduled_narinfo_removal"
+   (lambda ()
+     (call-with-worker-thread
+      (database-reader-thread-channel database)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                "
+SELECT removal_datetime
+FROM scheduled_narinfo_removal
+WHERE narinfo_id = :narinfo_id"
+                #:cache? #t)))
+          (sqlite-bind-arguments
+           statement
+           #:narinfo_id narinfo-id)
+
+          (let ((result
+                 (match (sqlite-step statement)
+                   (#(datetime)
+                    (date->time-utc
+                     (string->date
+                      datetime
+                      "~Y-~m-~d ~H:~M:~S")))
+                   (#f #f))))
+            (sqlite-reset statement)
+            result)))))))
+
+(define (database-select-scheduled-cached-narinfo-removal database
+                                                          cached-narinfo-file-id)
+  (call-with-time-tracking
+   database
+   "select_scheduled_narinfo_removal"
+   (lambda ()
+     (call-with-worker-thread
+      (database-reader-thread-channel database)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                "
+SELECT removal_datetime
+FROM scheduled_cached_narinfo_removal
+WHERE cached_narinfo_file_id = :cached_narinfo_file_id"
+                #:cache? #t)))
+          (sqlite-bind-arguments
+           statement
+           #:cached_narinfo_file_id cached-narinfo-file-id)
+
+          (let ((result
+                 (match (sqlite-step statement)
+                   (#(datetime)
+                    (date->time-utc
+                     (string->date
+                      datetime
+                      "~Y-~m-~d ~H:~M:~S")))
+                   (#f #f))))
+            (sqlite-reset statement)
+            result)))))))
+
+(define (database-delete-scheduled-cached-narinfo-removal database
+                                                          cached-narinfo-file-id)
+  (call-with-worker-thread
+   (database-writer-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+DELETE FROM scheduled_cached_narinfo_removal
+WHERE cached_narinfo_file_id = :cached_narinfo_file_id"
+             #:cache? #t)))
+       (sqlite-bind-arguments
+        statement
+        #:cached_narinfo_file_id cached-narinfo-file-id)
+
+       (sqlite-step statement)
+       (sqlite-reset statement)
+
+       #t))))
+
+(define (database-select-oldest-scheduled-cached-narinfo-removal database)
+  (call-with-worker-thread
+   (database-reader-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT cached_narinfo_files.id,
+       cached_narinfo_files.narinfo_id,
+       cached_narinfo_files.size,
+       cached_narinfo_files.compression,
+       narinfos.store_path,
+       scheduled_cached_narinfo_removal.removal_datetime
+FROM scheduled_cached_narinfo_removal
+INNER JOIN cached_narinfo_files
+  ON scheduled_cached_narinfo_removal.cached_narinfo_file_id =
+     cached_narinfo_files.id
+INNER JOIN narinfos
+  ON cached_narinfo_files.narinfo_id = narinfos.id
+ORDER BY scheduled_cached_narinfo_removal.removal_datetime DESC
+LIMIT 1"
+             #:cache? #t)))
+
+       (let ((result
+              (match (sqlite-step statement)
+                (#(id narinfo_id size compression store_path datetime)
+                 `((id                     . ,id)
+                   (narinfo-id             . ,narinfo_id)
+                   (size                   . ,size)
+                   (compression            . ,(string->symbol compression))
+                   (store-path             . ,store_path)
+                   (scheduled-removal-time . ,(date->time-utc
+                                               (string->date
+                                                datetime
+                                                "~Y-~m-~d ~H:~M:~S")))))
+                (#f #f))))
+         (sqlite-reset statement)
+         result)))))
+
+(define (database-insert-scheduled-cached-narinfo-removal database
+                                                          cached-narinfo-file-id
+                                                          removal-datetime)
+  (call-with-worker-thread
+   (database-writer-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+INSERT INTO scheduled_cached_narinfo_removal (
+  cached_narinfo_file_id, removal_datetime
+) VALUES (
+  :cached_narinfo_file_id, :removal_datetime
+)"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:cached_narinfo_file_id cached-narinfo-file-id
+        #:removal_datetime (date->string
+                            (time-utc->date removal-datetime)
+                            "~Y-~m-~d ~H:~M:~S"))
+
+       (sqlite-step statement)
+       (sqlite-reset statement)
+
+       #t))))