Add #:readonly? to setup-database

To allow opening the database without write access.

1 files changed, 68 insertions, 64 deletions

diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index 7ce4aef..63eeac0 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -269,29 +269,31 @@ CREATE UNIQUE INDEX IF NOT EXISTS
       ON narinfo_files (url);"))
 
 (define* (setup-database database-file metrics-registry
-                         #:key (reader-threads 1))
+                         #:key (reader-threads 1)
+                         (readonly? #f))
   (define mmap-size #f)
 
-  (let ((db (db-open database-file)))
-    (sqlite-exec db "PRAGMA journal_mode=WAL;")
-    (sqlite-exec db "PRAGMA optimize;")
-    (sqlite-exec db "PRAGMA wal_checkpoint(TRUNCATE);")
+  (unless readonly?
+    (let ((db (db-open database-file)))
+      (sqlite-exec db "PRAGMA journal_mode=WAL;")
+      (sqlite-exec db "PRAGMA optimize;")
+      (sqlite-exec db "PRAGMA wal_checkpoint(TRUNCATE);")
 
-    (update-schema db)
+      (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))))
+      ;; (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))
+      (sqlite-close db)))
 
   (let ((reader-thread-channel
          (make-worker-thread-set
@@ -340,54 +342,56 @@ CREATE UNIQUE INDEX IF NOT EXISTS
                (current-error-port))))))
 
         (writer-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)
-            (db-optimize db
-                         database-file)
+         (if readonly?
+             #f
+             (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)
+                (db-optimize db
+                             database-file)
 
-            (sqlite-close db))
-          #:lifetime 500
-          #:expire-on-exception? #t
-          #:name "db w"
+                (sqlite-close db))
+              #:lifetime 500
+              #:expire-on-exception? #t
+              #:name "db w"
 
-          ;; SQLite doesn't support parallel writes
-          #:parallelism 1
-          #:delay-logger (let ((delay-metric
-                                (make-histogram-metric
-                                 metrics-registry
-                                 "database_write_delay_seconds")))
-                           (lambda (seconds-delayed proc)
-                             (metric-observe delay-metric seconds-delayed)
-                             (when (> seconds-delayed 1)
-                               (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)))))))
+              ;; SQLite doesn't support parallel writes
+              #:parallelism 1
+              #:delay-logger (let ((delay-metric
+                                    (make-histogram-metric
+                                     metrics-registry
+                                     "database_write_delay_seconds")))
+                               (lambda (seconds-delayed proc)
+                                 (metric-observe delay-metric seconds-delayed)
+                                 (when (> seconds-delayed 1)
+                                   (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