Add some instrumentation around the database

2 files changed, 108 insertions, 48 deletions

diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index 0a03cb1..61f5bb1 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -27,6 +27,7 @@
   #:use-module (web uri)
   #:use-module (sqlite3)
   #:use-module (fibers)
+  #:use-module (prometheus)
   #:use-module (guix narinfo)
   #:use-module (guix derivations)
   #:use-module (nar-herder utils)
@@ -54,11 +55,13 @@
             database-map-all-narinfo-files))
 
 (define-record-type <database>
-  (make-database database-file reader-thread-channel writer-thread-channel)
+  (make-database database-file reader-thread-channel writer-thread-channel
+                 metrics-registry)
   database?
   (database-file          database-file)
   (reader-thread-channel  database-reader-thread-channel)
-  (writer-thread-channel  database-writer-thread-channel))
+  (writer-thread-channel  database-writer-thread-channel)
+  (metrics-registry       database-metrics-registry))
 
 (define* (db-open database
                   #:key (write? #t))
@@ -138,7 +141,7 @@ SELECT name FROM sqlite_master WHERE type = 'table' AND name = :name")))
 
     (sqlite-finalize statement)))
 
-(define (setup-database database-file)
+(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;")
@@ -165,6 +168,17 @@ SELECT name FROM sqlite_master WHERE type = 'table' AND name = :name")))
           (min (max (current-processor-count)
                     2)
                64)
+          #:delay-logger (let ((delay-metric
+                                (make-histogram-metric
+                                 metrics-registry
+                                 "database_read_delay_seconds")))
+                           (lambda (seconds-delayed)
+                             (metric-observe delay-metric seconds-delayed)
+                             (when (> seconds-delayed 1)
+                               (format
+                                (current-error-port)
+                                "warning: database read delayed by ~1,2f seconds~%"
+                                seconds-delayed))))))
 
         (writer-thread-channel
          (make-worker-thread-channel
@@ -183,11 +197,23 @@ SELECT name FROM sqlite_master WHERE type = 'table' AND name = :name")))
           #:lifetime 500
 
           ;; SQLite doesn't support parallel writes
-          #:parallelism 1)))
+          #:parallelism 1
+          #:delay-logger (let ((delay-metric
+                                (make-histogram-metric
+                                 metrics-registry
+                                 "database_write_delay_seconds")))
+                           (lambda (seconds-delayed)
+                             (metric-observe delay-metric seconds-delayed)
+                             (when (> seconds-delayed 1)
+                               (format
+                                (current-error-port)
+                                "warning: database write delayed by ~1,2f seconds~%"
+                                seconds-delayed)))))))
 
     (make-database database-file
                    reader-thread-channel
-                   writer-thread-channel)))
+                   writer-thread-channel
+                   metrics-registry)))
 
 (define (db-optimize db db-filename)
   (define (wal-size)
@@ -235,6 +261,24 @@ PRAGMA optimize;")))
          #:unwind? #t)))
    #:parallel? #t))
 
+(define (call-with-time-tracking database thing thunk)
+  (define registry (database-metrics-registry database))
+  (define metric-name
+    (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))
+      (thunk)))
+
 (define %current-transaction-proc
   (make-parameter #f))
 
@@ -647,24 +691,28 @@ DELETE FROM narinfo_tags WHERE narinfo_id = :narinfo_id"
        #t))))
 
 (define (database-select-narinfo-contents-by-hash database hash)
-  (call-with-worker-thread
-   (database-reader-thread-channel database)
-   (lambda (db)
-     (let ((statement
-            (sqlite-prepare
-             db
-             "
+  (call-with-time-tracking
+   database
+   "select_narinfo_contents_by_hash"
+   (lambda ()
+     (call-with-worker-thread
+      (database-reader-thread-channel database)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                "
 SELECT contents FROM narinfos WHERE substr(store_path, 12, 32) = :hash"
-             #:cache? #t)))
-       (sqlite-bind-arguments
-        statement
-        #:hash hash)
+                #:cache? #t)))
+          (sqlite-bind-arguments
+           statement
+           #:hash hash)
 
-       (match (let ((result (sqlite-step statement)))
-                (sqlite-reset statement)
-                result)
-         (#(contents) contents)
-         (_ #f))))))
+          (match (let ((result (sqlite-step statement)))
+                   (sqlite-reset statement)
+                   result)
+            (#(contents) contents)
+            (_ #f))))))))
 
 (define* (database-select-recent-changes database after-date #:key (limit 8192))
   (call-with-worker-thread
@@ -787,35 +835,39 @@ WHERE narinfo_files.url = :url"
             (contents   . ,contents))))))))
 
 (define (database-select-narinfo-files database hash)
-  (call-with-worker-thread
-   (database-reader-thread-channel database)
-   (lambda (db)
-     (let ((statement
-            (sqlite-prepare
-             db
-             "
+  (call-with-time-tracking
+   database
+   "select_narinfo_files"
+   (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 substr(narinfos.store_path, 12, 32) = :hash"
-             #:cache? #t)))
+                #:cache? #t)))
 
-       (sqlite-bind-arguments
-        statement
-        #:hash hash)
-
-       (let ((result
-              (sqlite-map
-               (match-lambda
-                 (#(size compression url)
-                  `((size        . ,size)
-                    (compression . ,compression)
-                    (url         . ,url))))
-               statement)))
-         (sqlite-reset statement)
+          (sqlite-bind-arguments
+           statement
+           #:hash hash)
+
+          (let ((result
+                 (sqlite-map
+                  (match-lambda
+                    (#(size compression url)
+                     `((size        . ,size)
+                       (compression . ,compression)
+                       (url         . ,url))))
+                  statement)))
+            (sqlite-reset statement)
 
-         result)))))
+            result)))))))
 
 (define (database-map-all-narinfo-files database proc)
   (call-with-worker-thread
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index 8ade7fb..d1f95d1 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -211,8 +211,12 @@
                                (append %base-option-defaults
                                        %import-options-defaults)
                                rest))
+          (metrics-registry
+           (make-metrics-registry #:namespace
+                                  "narherder"))
           (database (setup-database
-                     (assq-ref opts 'database))))
+                     (assq-ref opts 'database)
+                     metrics-registry)))
      (let* ((narinfos
              (append-map
               (lambda (file-or-dir)
@@ -258,8 +262,12 @@
    (let* ((opts (parse-options %base-options
                                %base-option-defaults
                                rest))
+          (metrics-registry
+           (make-metrics-registry #:namespace
+                                  "narherder"))
           (database (setup-database
-                     (assq-ref opts 'database)))
+                     (assq-ref opts 'database)
+                     metrics-registry))
           (lgr (make <logger>))
           (port-log (make <port-log>
                       #:port (current-output-port)
@@ -287,8 +295,7 @@
               (remove-nar-files-by-hash
                database
                (assq-ref opts 'storage)
-               (make-metrics-registry #:namespace
-                                      "narherder")
+               metrics-registry
                (store-path-hash-part store-path)))
             (log-msg
              'WARN "no --storage set, so just removing from the database"))
@@ -386,7 +393,8 @@
                 #f)
               (download-database)))))
 
-     (let ((database (setup-database (assq-ref opts 'database)))
+     (let ((database (setup-database (assq-ref opts 'database)
+                                     metrics-registry))
            (canonical-storage (and=> (assq-ref opts 'storage)
                                      canonicalize-path)))