aboutsummaryrefslogtreecommitdiff
path: root/nar-herder/database.scm
diff options
context:
space:
mode:
Diffstat (limited to 'nar-herder/database.scm')
-rw-r--r--nar-herder/database.scm1006
1 files changed, 879 insertions, 127 deletions
diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index 61f5bb1..ded7c2c 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -28,10 +28,12 @@
#:use-module (sqlite3)
#:use-module (fibers)
#:use-module (prometheus)
+ #:use-module (guix store)
#:use-module (guix narinfo)
#:use-module (guix derivations)
#:use-module (nar-herder utils)
#:export (setup-database
+ update-database-metrics!
database-optimize
database-spawn-fibers
@@ -42,8 +44,11 @@
database-insert-narinfo
database-remove-narinfo
+ database-select-narinfo
+ database-select-narinfo-by-hash
database-select-narinfo-contents-by-hash
+ database-count-recent-changes
database-select-recent-changes
database-select-latest-recent-change-datetime
database-get-recent-changes-id-for-deletion
@@ -51,8 +56,25 @@
database-select-narinfo-for-file
database-select-narinfo-files
-
- database-map-all-narinfo-files))
+ database-select-narinfo-files-by-narinfo-id
+
+ database-fold-all-narinfo-files
+ database-map-all-narinfo-files
+ database-count-narinfo-files
+
+ database-insert-cached-narinfo-file
+ database-select-cached-narinfo-file-by-hash
+ database-select-cached-narinfo-file-by-narinfo-id-and-compression
+ database-select-cached-narinfo-files-by-narinfo-id
+ database-fold-cached-narinfo-files
+ 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-count-scheduled-cached-narinfo-removal
+ database-insert-scheduled-cached-narinfo-removal))
(define-record-type <database>
(make-database database-file reader-thread-channel writer-thread-channel
@@ -85,7 +107,8 @@ CREATE TABLE narinfos (
nar_size INTEGER NOT NULL,
deriver TEXT,
system TEXT,
- contents NOT NULL
+ contents NOT NULL,
+ added_at TEXT
);
CREATE UNIQUE INDEX narinfos_store_hash ON narinfos (substr(store_path, 12, 32));
@@ -97,6 +120,8 @@ CREATE TABLE narinfo_files (
url TEXT NOT NULL
);
+CREATE INDEX narinfo_files_narinfo_id ON narinfo_files (narinfo_id);
+
CREATE TABLE narinfo_references (
narinfo_id INTEGER NOT NULL REFERENCES narinfos (id),
store_path TEXT NOT NULL
@@ -120,28 +145,124 @@ 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);
+
+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))
-(define (update-schema db)
+(define (table-exists? db name)
(let ((statement
(sqlite-prepare
db
"
-SELECT name FROM sqlite_master WHERE type = 'table' AND name = :name")))
+SELECT 1 FROM sqlite_master WHERE type = 'table' AND name = :name")))
(sqlite-bind-arguments
statement
- #:name "narinfos")
+ #:name name)
+
+ (let ((result
+ (match (sqlite-step statement)
+ (#f #f)
+ (#(1) #t))))
+ (sqlite-finalize statement)
- (match (sqlite-step statement)
- (#f (perform-initial-database-setup db))
- (_ #f))
+ result)))
+
+(define (column-exists? db table-name column-name)
+ (let ((statement
+ (sqlite-prepare
+ db
+ (simple-format #f "PRAGMA table_info(~A);" table-name))))
+
+ (let ((columns
+ (sqlite-map
+ (lambda (row)
+ (vector-ref row 1))
+ statement)))
+ (sqlite-finalize statement)
+
+ (member column-name columns))))
+
+(define (update-schema db)
+ (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
+);
- (sqlite-finalize statement)))
+CREATE INDEX cached_narinfo_files_narinfo_id
+ ON cached_narinfo_files (narinfo_id);"))
+
+ (unless (column-exists? db "narinfos" "added_at")
+ (sqlite-exec
+ 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
+ ON narinfo_tags (narinfo_id);")
+
+ (sqlite-exec
+ db
+ "CREATE INDEX IF NOT EXISTS narinfo_references_narinfo_id
+ ON narinfo_references (narinfo_id);")
+
+ (sqlite-exec
+ db
+ "CREATE INDEX IF NOT EXISTS narinfo_files_narinfo_id
+ ON narinfo_files (narinfo_id);"))
+
+(define* (setup-database database-file metrics-registry
+ #:key (reader-threads 1))
+ (define mmap-size #f)
-(define (setup-database database-file metrics-registry)
(let ((db (db-open database-file)))
(sqlite-exec db "PRAGMA journal_mode=WAL;")
(sqlite-exec db "PRAGMA optimize;")
@@ -149,44 +270,77 @@ SELECT name FROM sqlite_master WHERE type = 'table' AND name = :name")))
(update-schema db)
+ ;; (let ((requested-mmap-bytes 2147418112)
+ ;; (statement
+ ;; (sqlite-prepare
+ ;; db
+ ;; (simple-format #f "PRAGMA mmap_size=~A;"
+ ;; 2147418112))))
+ ;; (match (sqlite-step statement)
+ ;; (#(result-mmap-size)
+ ;; (sqlite-finalize statement)
+ ;; (set! mmap-size
+ ;; result-mmap-size))))
+
(sqlite-close db))
(let ((reader-thread-channel
- (make-worker-thread-channel
+ (make-worker-thread-set
(lambda ()
(let ((db
(db-open database-file #:write? #f)))
(sqlite-exec db "PRAGMA busy_timeout = 5000;")
+ (when mmap-size
+ (sqlite-exec
+ db
+ (simple-format #f "PRAGMA mmap_size=~A;"
+ (number->string mmap-size))))
(list db)))
#:destructor
(lambda (db)
(sqlite-close db))
#:lifetime 50000
+ #:name "db r"
;; Use a minimum of 2 and a maximum of 8 threads
- #:parallelism
- (min (max (current-processor-count)
- 2)
- 64)
+ #:parallelism reader-threads
#:delay-logger (let ((delay-metric
(make-histogram-metric
metrics-registry
"database_read_delay_seconds")))
- (lambda (seconds-delayed)
+ (lambda (seconds-delayed proc)
(metric-observe delay-metric seconds-delayed)
(when (> seconds-delayed 1)
- (format
- (current-error-port)
- "warning: database read delayed by ~1,2f seconds~%"
- seconds-delayed))))))
+ (display
+ (format
+ #f
+ "warning: database read (~a) delayed by ~1,2f seconds~%"
+ proc
+ seconds-delayed)
+ (current-error-port)))))
+ #:duration-logger
+ (lambda (duration proc)
+ (when (> duration 5)
+ (display
+ (format
+ #f
+ "warning: database read took ~1,2f seconds (~a)~%"
+ duration
+ proc)
+ (current-error-port))))))
(writer-thread-channel
- (make-worker-thread-channel
+ (make-worker-thread-set
(lambda ()
(let ((db
(db-open database-file)))
(sqlite-exec db "PRAGMA busy_timeout = 5000;")
(sqlite-exec db "PRAGMA foreign_keys = ON;")
+ (when mmap-size
+ (sqlite-exec
+ db
+ (simple-format #f "PRAGMA mmap_size=~A;"
+ (number->string mmap-size))))
(list db)))
#:destructor
(lambda (db)
@@ -195,6 +349,7 @@ SELECT name FROM sqlite_master WHERE type = 'table' AND name = :name")))
(sqlite-close db))
#:lifetime 500
+ #:name "db w"
;; SQLite doesn't support parallel writes
#:parallelism 1
@@ -202,19 +357,56 @@ SELECT name FROM sqlite_master WHERE type = 'table' AND name = :name")))
(make-histogram-metric
metrics-registry
"database_write_delay_seconds")))
- (lambda (seconds-delayed)
+ (lambda (seconds-delayed proc)
(metric-observe delay-metric seconds-delayed)
(when (> seconds-delayed 1)
- (format
- (current-error-port)
- "warning: database write delayed by ~1,2f seconds~%"
- seconds-delayed)))))))
+ (display
+ (format
+ #f
+ "warning: database write (~a) delayed by ~1,2f seconds~%"
+ proc
+ seconds-delayed)
+ (current-error-port)))))
+ #:duration-logger
+ (lambda (duration proc)
+ (when (> duration 5)
+ (display
+ (format
+ #f
+ "warning: database write took ~1,2f seconds (~a)~%"
+ duration
+ proc)
+ (current-error-port)))))))
(make-database database-file
reader-thread-channel
writer-thread-channel
metrics-registry)))
+(define (update-database-metrics! database)
+ (let* ((db-filename (database-file database))
+ (db-wal-filename
+ (string-append db-filename "-wal"))
+
+ (registry (database-metrics-registry database))
+ (db-bytes
+ (or (metrics-registry-fetch-metric registry
+ "database_bytes")
+ (make-gauge-metric
+ registry "database_bytes"
+ #:docstring "Size of the SQLite database file")))
+ (db-wal-bytes
+ (or (metrics-registry-fetch-metric registry
+ "database_wal_bytes")
+ (make-gauge-metric
+ registry "database_wal_bytes"
+ #:docstring "Size of the SQLite Write Ahead Log file"))))
+
+
+ (metric-set db-bytes (stat:size (stat db-filename)))
+ (metric-set db-wal-bytes (stat:size (stat db-wal-filename))))
+ #t)
+
(define (db-optimize db db-filename)
(define (wal-size)
(let ((db-wal-filename
@@ -267,43 +459,110 @@ PRAGMA optimize;")))
(string-append "database_" thing "_duration_seconds"))
(if registry
- (let* ((metric
- (or (metrics-registry-fetch-metric registry metric-name)
- (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-duration-metric registry
+ metric-name
+ thunk)
(thunk)))
(define %current-transaction-proc
(make-parameter #f))
(define* (database-call-with-transaction database proc
- #:key
- readonly?)
+ #:key
+ readonly?
+ (immediate? (not readonly?)))
(define (run-proc-within-transaction db)
- (if (%current-transaction-proc)
- (proc db) ; already in transaction
- (begin
- (sqlite-exec db "BEGIN TRANSACTION;")
- (with-exception-handler
- (lambda (exn)
- (simple-format (current-error-port)
- "error: sqlite rolling back transaction\n")
- (sqlite-exec db "ROLLBACK TRANSACTION;")
- (raise-exception exn))
+ (define (attempt-begin)
+ (with-exception-handler
+ (lambda (exn)
+ (match (exception-args exn)
+ (('sqlite-exec 5 msg)
+ (simple-format
+ (current-error-port)
+ "warning: issue starting transaction (code: 5, proc: ~A): ~A\n"
+ proc msg)
+ #f)
+ (_
+ (simple-format (current-error-port)
+ "exception starting transaction: ~A\n" exn)
+ (raise-exception exn))))
+ (lambda ()
+ (sqlite-exec db (if immediate?
+ "BEGIN IMMEDIATE TRANSACTION;"
+ "BEGIN TRANSACTION;"))
+ #t)
+ #:unwind? #t))
+
+ (define (attempt-commit)
+ (with-exception-handler
+ (lambda (exn)
+ (match (exception-args exn)
+ (('sqlite-exec 5 msg)
+ (simple-format
+ (current-error-port)
+ "warning: attempt commit (code: 5, proc: ~A): ~A\n"
+ proc msg)
+ #f)
+ (_
+ (simple-format (current-error-port)
+ "exception committing transaction: ~A\n" exn)
+ (raise-exception exn))))
+ (lambda ()
+ (sqlite-exec db "COMMIT TRANSACTION;")
+ #t)
+ #:unwind? #t))
+
+ (if (attempt-begin)
+ (call-with-values
(lambda ()
- (call-with-values
- (lambda ()
- (parameterize ((%current-transaction-proc proc))
- (proc db)))
- (lambda vals
- (sqlite-exec db "COMMIT TRANSACTION;")
- (apply values vals))))))))
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format (current-error-port)
+ "error: sqlite rolling back transaction (~A)\n"
+ exn)
+ (sqlite-exec db "ROLLBACK TRANSACTION;")
+ (raise-exception exn))
+ (lambda ()
+ (parameterize ((%current-transaction-proc proc))
+ (proc-with-duration-timing db)))
+ #:unwind? #t))
+ (lambda vals
+ (let loop ((success? (attempt-commit)))
+ (if success?
+ (apply values vals)
+ (loop (attempt-commit))))))
+
+ ;; Database is busy, so retry
+ (run-proc-within-transaction db)))
+
+ (define (proc-with-duration-timing db)
+ (let ((start-time (get-internal-real-time)))
+ (call-with-values
+ (lambda ()
+ (with-throw-handler #t
+ (lambda ()
+ (proc db))
+ (lambda (key . args)
+ (simple-format
+ (current-error-port)
+ "exception in transaction: ~A: ~A\n"
+ key args)
+ (backtrace))))
+ (lambda vals
+ (let ((duration-seconds
+ (/ (- (get-internal-real-time) start-time)
+ internal-time-units-per-second)))
+ (when (and (not readonly?)
+ (> duration-seconds 2))
+ (display
+ (format
+ #f
+ "warning: ~a:\n took ~4f seconds in transaction\n"
+ proc
+ duration-seconds)
+ (current-error-port)))
+
+ (cons duration-seconds vals))))))
(match (call-with-worker-thread
((if readonly?
@@ -311,25 +570,9 @@ PRAGMA optimize;")))
database-writer-thread-channel)
database)
(lambda (db)
- (let ((start-time (get-internal-real-time)))
- (call-with-values
- (lambda ()
- (run-proc-within-transaction db))
- (lambda vals
- (let ((duration-seconds
- (/ (- (get-internal-real-time) start-time)
- internal-time-units-per-second)))
- (when (and (not readonly?)
- (> duration-seconds 2))
- (display
- (format
- #f
- "warning: ~a:\n took ~4f seconds in transaction\n"
- proc
- duration-seconds)
- (current-error-port)))
-
- (cons duration-seconds vals)))))))
+ (if (%current-transaction-proc)
+ (proc-with-duration-timing db) ; already in transaction
+ (run-proc-within-transaction db))))
((duration vals ...)
(apply values vals))))
@@ -417,9 +660,9 @@ SELECT id FROM tags WHERE key = :key AND value = :value"
db
"
INSERT INTO narinfos (
- store_path, nar_hash, nar_size, deriver, system, contents
+ store_path, nar_hash, nar_size, deriver, system, contents, added_at
) VALUES (
- :store_path, :nar_hash, :nar_size, :deriver, :system, :contents
+ :store_path, :nar_hash, :nar_size, :deriver, :system, :contents, :added_at
)"
#:cache? #t)))
(sqlite-bind-arguments
@@ -429,7 +672,8 @@ INSERT INTO narinfos (
#:nar_size (narinfo-size narinfo)
#:deriver (narinfo-deriver narinfo)
#:system (narinfo-system narinfo)
- #:contents (narinfo-contents narinfo))
+ #:contents (narinfo-contents narinfo)
+ #:added_at (date->string (current-date) "~1 ~3"))
(sqlite-step statement)
(sqlite-reset statement)
@@ -563,23 +807,6 @@ INSERT INTO narinfo_tags (narinfo_id, tag_id) VALUES (:narinfo_id, :tag_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
@@ -677,18 +904,90 @@ DELETE FROM narinfo_tags WHERE narinfo_id = :narinfo_id"
(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))
+ (let ((narinfo-details
+ (database-select-narinfo-by-hash
+ database
+ (store-path-hash-part store-path))))
+ (if narinfo-details
+ (let ((narinfo-id (assq-ref narinfo-details
+ 'id)))
+ (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)
+ #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)
- (remove-narinfo-files db narinfo-id)
- (remove-narinfo-references db narinfo-id)
- (remove-tags db narinfo-id)
- (remove-narinfo-record db narinfo-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
+ "select_narinfo_by_hash"
+ (lambda ()
+ (call-with-worker-thread
+ (database-reader-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT id, store_path, nar_hash, nar_size, deriver, system
+FROM narinfos
+WHERE substr(store_path, 12, 32) = :hash"
+ #:cache? #t)))
+ (sqlite-bind-arguments
+ statement
+ #:hash hash)
- #t))))
+ (match (let ((result (sqlite-step statement)))
+ (sqlite-reset statement)
+ result)
+ (#(id store_path nar_hash nar_size deriver system)
+ `((id . ,id)
+ (store-path . ,store_path)
+ (nar-hash . ,nar_hash)
+ (nar-size . ,nar_size)
+ (deriver . ,deriver)
+ (system . ,system)))
+ (_
+ #f))))))))
(define (database-select-narinfo-contents-by-hash database hash)
(call-with-time-tracking
@@ -702,7 +1001,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
@@ -711,8 +1010,27 @@ 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-count-recent-changes database)
+ (call-with-worker-thread
+ (database-reader-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT COUNT(*) FROM recent_changes"
+ #:cache? #t)))
+
+ (let ((result
+ (match (sqlite-step statement)
+ (#(count) count))))
+ (sqlite-reset statement)
+ result)))))
(define* (database-select-recent-changes database after-date #:key (limit 8192))
(call-with-worker-thread
@@ -722,26 +1040,27 @@ SELECT contents FROM narinfos WHERE substr(store_path, 12, 32) = :hash"
(sqlite-prepare
db
"
-SELECT datetime, change, data FROM recent_changes WHERE datetime >= :datetime LIMIT :limit"
+SELECT datetime, change, data
+FROM recent_changes
+WHERE datetime >= :datetime
+ORDER BY datetime ASC
+LIMIT :limit"
#:cache? #t)))
(sqlite-bind-arguments
statement
#:datetime after-date
#:limit limit)
- (let loop ((row (sqlite-step statement))
- (result '()))
- (match row
- (#(datetime change data)
- (loop (sqlite-step statement)
- (cons `((datetime . ,datetime)
- (change . ,change)
- (data . ,data))
- result)))
- (#f
- (sqlite-reset statement)
-
- (reverse result))))))))
+ (let ((result
+ (sqlite-map
+ (match-lambda
+ (#(datetime change data)
+ `((datetime . ,datetime)
+ (change . ,change)
+ (data . ,data))))
+ statement)))
+ (sqlite-reset statement)
+ result)))))
(define (database-select-latest-recent-change-datetime database)
(call-with-worker-thread
@@ -869,7 +1188,42 @@ WHERE substr(narinfos.store_path, 12, 32) = :hash"
result)))))))
-(define (database-map-all-narinfo-files database proc)
+(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)
+ (url . ,url))))
+ statement)))
+ (sqlite-reset statement)
+
+ result)))))))
+
+(define (database-fold-all-narinfo-files database proc init)
(call-with-worker-thread
(database-reader-thread-channel database)
(lambda (db)
@@ -885,12 +1239,410 @@ FROM narinfo_files"
(lambda (row result)
(match row
(#(size compression url)
- (cons (proc `((size . ,size)
- (compression . ,compression)
- (url . ,url)))
+ (proc `((size . ,size)
+ (compression . ,compression)
+ (url . ,url))
+ result))))
+ init
+ statement)))
+ (sqlite-reset statement)
+
+ result-list)))))
+
+(define (database-map-all-narinfo-files database proc)
+ (database-fold-all-narinfo-files
+ database
+ (lambda (nar-file result)
+ (cons (proc nar-file)
+ result))
+ '()))
+
+(define (database-count-narinfo-files database)
+ (call-with-worker-thread
+ (database-reader-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT COUNT(*) FROM narinfo_files"
+ #:cache? #t)))
+
+ (let ((result
+ (vector-ref (sqlite-step statement)
+ 0)))
+ (sqlite-reset statement)
+
+ result)))))
+
+(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 (symbol->string 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.id, 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 (symbol->string compression))
+
+ (let ((result
+ (match (sqlite-step statement)
+ (#(id size)
+ `((id . ,id)
+ (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 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"
+ #:cache? #t)))
+
+ (sqlite-bind-arguments
+ statement
+ #:narinfo_id narinfo-id)
+
+ (let ((result
+ (sqlite-map
+ (match-lambda
+ (#(id store_path size compression)
+ `((id . ,id)
+ (store-path . ,store_path)
+ (size . ,size)
+ (compression . ,(string->symbol compression)))))
+ statement)))
+ (sqlite-reset statement)
+
+ 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)
+ (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)))))
+
+(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
+RETURNING 1"
+ #:cache? #t)))
+ (sqlite-bind-arguments
+ statement
+ #:cached_narinfo_file_id cached-narinfo-file-id)
+
+ (let ((result (->bool (sqlite-step statement))))
+ (sqlite-reset statement)
+
+ result)))))
+
+(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-count-scheduled-cached-narinfo-removal database)
+ (call-with-worker-thread
+ (database-reader-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT COUNT(*) FROM scheduled_cached_narinfo_removal"
+ #:cache? #t)))
+
+ (let ((result
+ (vector-ref (sqlite-step statement)
+ 0)))
+ (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))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-05-06 11:02:11 +0000