Add experimental support for cached compressions

This adds optional caching for alternative compressions of stored
nars. You could store lzip nars for example, but then compute, cache
and provide zstd nars for some stored nars.

1 files changed, 235 insertions, 11 deletions

diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index d945786..028fb50 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -51,8 +51,15 @@
 
             database-select-narinfo-for-file
             database-select-narinfo-files
+            database-select-narinfo-files-by-narinfo-id
 
-            database-map-all-narinfo-files))
+            database-map-all-narinfo-files
+
+            database-insert-cached-narinfo-file
+            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))
 
 (define-record-type <database>
   (make-database database-file reader-thread-channel writer-thread-channel
@@ -122,7 +129,17 @@ CREATE TABLE recent_changes (
   datetime TEXT NOT NULL,
   change TEXT NOT NULl,
   data TEXT NOT NULL
-);")
+);
+
+CREATE TABLE cached_narinfo_files (
+  id INTEGER PRIMARY KEY ASC,
+  narinfo_id INTEGER NOT NULL REFERENCES narinfos (id),
+  size INTEGER NOT NULL,
+  compression TEXT,
+);
+
+CREATE INDEX cached_narinfo_files_narinfo_id
+  ON cached_narinfo_files (narinfo_id);")
 
   (sqlite-exec db schema))
 
@@ -149,6 +166,20 @@ SELECT 1 FROM sqlite_master WHERE type = 'table' AND name = :name")))
   (unless (table-exists? db "narinfos")
     (perform-initial-database-setup db))
 
+  (unless (table-exists? db "cached_narinfo_files")
+    (sqlite-exec
+     db
+     "
+CREATE TABLE cached_narinfo_files (
+  id INTEGER PRIMARY KEY ASC,
+  narinfo_id INTEGER NOT NULL REFERENCES narinfos (id),
+  size INTEGER NOT NULL,
+  compression TEXT NOT NULL
+);
+
+CREATE INDEX cached_narinfo_files_narinfo_id
+  ON cached_narinfo_files (narinfo_id);"))
+
   (sqlite-exec
    db
    "CREATE INDEX IF NOT EXISTS narinfo_files_narinfo_id
@@ -285,11 +316,13 @@ PRAGMA optimize;")))
                   (make-histogram-metric registry
                                          metric-name)))
              (start-time (get-internal-real-time)))
-        (let ((result (thunk)))
-          (metric-observe metric
-                          (/ (- (get-internal-real-time) start-time)
-                             internal-time-units-per-second))
-          result))
+        (call-with-values
+            thunk
+          (lambda vals
+            (metric-observe metric
+                            (/ (- (get-internal-real-time) start-time)
+                               internal-time-units-per-second))
+            (apply values vals))))
       (thunk)))
 
 (define %current-transaction-proc
@@ -715,7 +748,7 @@ DELETE FROM narinfo_tags WHERE narinfo_id = :narinfo_id"
                (sqlite-prepare
                 db
                 "
-SELECT contents FROM narinfos WHERE substr(store_path, 12, 32) = :hash"
+SELECT id, contents FROM narinfos WHERE substr(store_path, 12, 32) = :hash"
                 #:cache? #t)))
           (sqlite-bind-arguments
            statement
@@ -724,8 +757,10 @@ SELECT contents FROM narinfos WHERE substr(store_path, 12, 32) = :hash"
           (match (let ((result (sqlite-step statement)))
                    (sqlite-reset statement)
                    result)
-            (#(contents) contents)
-            (_ #f))))))))
+            (#(id contents)
+             (values contents id))
+            (_
+             (values #f #f)))))))))
 
 (define* (database-select-recent-changes database after-date #:key (limit 8192))
   (call-with-worker-thread
@@ -859,7 +894,7 @@ WHERE narinfo_files.url = :url"
                (sqlite-prepare
                 db
                 "
-SELECT narinfo_files.size, narinfo_files.compression, narinfo_files.url
+SELECT narinfo_files.size, narinfo_files.compression, narinfo_files.url, narinfos.id
 FROM narinfos
 INNER JOIN narinfo_files
   ON narinfos.id = narinfo_files.narinfo_id
@@ -873,6 +908,42 @@ WHERE substr(narinfos.store_path, 12, 32) = :hash"
           (let ((result
                  (sqlite-map
                   (match-lambda
+                    (#(size compression url narinfo-id)
+                     `((size        . ,size)
+                       (compression . ,compression)
+                       (url         . ,url)
+                       (narinfo-id  . ,narinfo-id))))
+                  statement)))
+            (sqlite-reset statement)
+
+            result)))))))
+
+(define (database-select-narinfo-files-by-narinfo-id database narinfo-id)
+  (call-with-time-tracking
+   database
+   "select_narinfo_files_by_narinfo_id"
+   (lambda ()
+     (call-with-worker-thread
+      (database-reader-thread-channel database)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                "
+SELECT narinfo_files.size, narinfo_files.compression, narinfo_files.url
+FROM narinfos
+INNER JOIN narinfo_files
+  ON narinfos.id = narinfo_files.narinfo_id
+WHERE narinfos.id = :narinfo_id"
+                #:cache? #t)))
+
+          (sqlite-bind-arguments
+           statement
+           #:narinfo_id narinfo-id)
+
+          (let ((result
+                 (sqlite-map
+                  (match-lambda
                     (#(size compression url)
                      `((size        . ,size)
                        (compression . ,compression)
@@ -907,3 +978,156 @@ FROM narinfo_files"
          (sqlite-reset statement)
 
          result-list)))))
+
+(define (database-insert-cached-narinfo-file database
+                                             narinfo-id
+                                             size
+                                             compression)
+  (call-with-worker-thread
+   (database-writer-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+INSERT INTO cached_narinfo_files (
+  narinfo_id, size, compression
+) VALUES (
+  :narinfo_id, :size, :compression
+)"
+             #:cache? #t)))
+       (sqlite-bind-arguments
+        statement
+        #:narinfo_id narinfo-id
+        #:size size
+        #:compression compression)
+
+       (sqlite-step statement)
+       (sqlite-reset statement)
+
+       (last-insert-rowid db)))))
+
+(define (database-select-cached-narinfo-file-by-hash database
+                                                     hash
+                                                     compression)
+  (call-with-time-tracking
+   database
+   "select_cached_narinfo_file_by_hash"
+   (lambda ()
+     (call-with-worker-thread
+      (database-reader-thread-channel database)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                "
+SELECT cached_narinfo_files.size
+FROM narinfos
+INNER JOIN cached_narinfo_files
+  ON cached_narinfo_files.narinfo_id = narinfos.id
+WHERE substr(narinfos.store_path, 12, 32) = :hash
+  AND cached_narinfo_files.compression = :compression"
+                #:cache? #t)))
+
+          (sqlite-bind-arguments
+           statement
+           #:hash hash
+           #:compression compression)
+
+          (let ((result
+                 (match (sqlite-step statement)
+                   (#(size)
+                    `((size . ,size)))
+                   (#f #f))))
+            (sqlite-reset statement)
+
+            result)))))))
+
+(define (database-select-cached-narinfo-files-by-narinfo-id
+         database
+         narinfo-id)
+  (call-with-time-tracking
+   database
+   "select_cached_narinfo_file_by_narinfo_id"
+   (lambda ()
+     (call-with-worker-thread
+      (database-reader-thread-channel database)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                "
+SELECT store_path, size, compression
+FROM cached_narinfo_files
+INNER JOIN narinfos
+  ON cached_narinfo_files.narinfo_id = narinfos.id
+WHERE narinfo_id = :narinfo_id"
+                #:cache? #t)))
+
+          (sqlite-bind-arguments
+           statement
+           #:narinfo_id narinfo-id)
+
+          (let ((result
+                 (sqlite-map
+                  (match-lambda
+                    (#(store_path size compression)
+                     `((store-path  . ,store_path)
+                       (size        . ,size)
+                       (compression . ,(string->symbol compression)))))
+                  statement)))
+            (sqlite-reset statement)
+
+            result)))))))
+
+(define (database-fold-cached-narinfo-files database
+                                            proc
+                                            init)
+  (call-with-worker-thread
+   (database-reader-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT store_path, size, compression, narinfo_id
+FROM cached_narinfo_files
+INNER JOIN narinfos
+  ON cached_narinfo_files.narinfo_id = narinfos.id"
+             #:cache? #t)))
+       (let ((result-list
+              (sqlite-fold
+               (lambda (row result)
+                 (match row
+                   (#(store_path size compression narinfo_id)
+                    (proc `((size        . ,size)
+                            (compression . ,(string->symbol compression))
+                            (store-path  . ,store_path)
+                            (narinfo-id  . ,narinfo_id))
+                          result))))
+               init
+               statement)))
+         (sqlite-reset statement)
+
+         result-list)))))
+
+(define (database-remove-cached-narinfo-file database narinfo-id compression)
+  (call-with-worker-thread
+   (database-writer-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+DELETE FROM cached_narinfo_files
+WHERE narinfo_id = :narinfo_id
+  AND compression = :compression"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:narinfo_id narinfo-id
+        #:compression compression)
+
+       (sqlite-step statement)
+       (sqlite-reset statement)))))