Regularly update the database dump and delete recent changes

4 files changed, 137 insertions, 1 deletions

diff --git a/Makefile.am b/Makefile.am
index 4438ba3..7ac77d7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -6,6 +6,7 @@ bin_SCRIPTS =						\
 SOURCES =						\
   nar-herder/database.scm				\
   nar-herder/server.scm				\
+  nar-herder/recent-changes.scm			\
   nar-herder/storage.scm				\
   nar-herder/mirror.scm				\
   nar-herder/utils.scm
diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index 399d527..e30c82a 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -44,6 +44,8 @@
 
             database-select-recent-changes
             database-select-latest-recent-change-datetime
+            database-get-recent-changes-id-for-deletion
+            database-delete-recent-changes-with-id-below
 
             database-select-narinfo-for-file
             database-select-narinfo-files
@@ -308,6 +310,20 @@ PRAGMA optimize;")))
 
       id)))
 
+(define (changes db)
+  (let ((statement
+         (sqlite-prepare
+          db
+          "SELECT changes()"
+          #:cache? #t)))
+    (let ((id
+           (vector-ref (sqlite-step statement)
+                       0)))
+
+      (sqlite-reset statement)
+
+      id)))
+
 (define (database-insert-narinfo database narinfo)
   (define (insert-narinfo-record db)
     (let ((statement
@@ -481,6 +497,48 @@ SELECT datetime FROM recent_changes ORDER BY datetime DESC LIMIT 1"
 
          result)))))
 
+(define (database-get-recent-changes-id-for-deletion database limit)
+  (call-with-worker-thread
+   (database-reader-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT id FROM recent_changes ORDER BY datetime DESC LIMIT 1 OFFSET :offset"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:offset limit)
+
+       (let ((result (match (sqlite-step statement)
+                       (#(id) id)
+                       (#f #f))))
+         (sqlite-reset statement)
+
+         result)))))
+
+(define (database-delete-recent-changes-with-id-below database id)
+  (call-with-worker-thread
+   (database-writer-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+DELETE FROM recent_changes WHERE id < :id"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:id id)
+
+       (sqlite-step statement)
+       (sqlite-reset statement)
+
+       (changes db)))))
+
 (define (database-select-narinfo-for-file database narinfo-file-url)
   (call-with-worker-thread
    (database-reader-thread-channel database)
diff --git a/nar-herder/recent-changes.scm b/nar-herder/recent-changes.scm
new file mode 100644
index 0000000..fee63f3
--- /dev/null
+++ b/nar-herder/recent-changes.scm
@@ -0,0 +1,63 @@
+;;; Nar Herder
+;;;
+;;; Copyright © 2021 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (nar-herder recent-changes)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 threads)
+  #:use-module (nar-herder database)
+  #:export (start-recent-change-removal-and-database-dump-thread))
+
+(define (start-recent-change-removal-and-database-dump-thread database
+                                                              database-dump-filename
+                                                              check-interval
+                                                              recent-changes-limit)
+  (define (update-database-dump)
+    (let ((temp-database-dump-filename
+           (string-append database-dump-filename ".tmp")))
+
+      (when (file-exists? temp-database-dump-filename)
+        (delete-file temp-database-dump-filename))
+
+      (dump-database database temp-database-dump-filename)
+
+      (rename-file temp-database-dump-filename
+                   database-dump-filename)
+
+      (simple-format (current-error-port)
+                     "updated database dump\n")))
+
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (let ((recent-changes-id-for-deletion
+              (database-get-recent-changes-id-for-deletion database
+                                                           recent-changes-limit)))
+         (when recent-changes-id-for-deletion
+           (update-database-dump)
+
+           (let ((deleted-recent-changes
+                  (database-delete-recent-changes-with-id-below
+                   database
+                   recent-changes-id-for-deletion)))
+             (simple-format (current-error-port)
+                            "deleted ~A recent changes\n"
+                            deleted-recent-changes)))
+
+         (sleep check-interval))))))
+
+
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index bbfaeea..a969910 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -55,6 +55,7 @@
              ((guix build utils) #:select (dump-port))
              (nar-herder utils)
              (nar-herder database)
+             (nar-herder recent-changes)
              (nar-herder storage)
              (nar-herder mirror)
              (nar-herder server))
@@ -115,6 +116,12 @@
                                  (cons (string->symbol sym) rest)))
                               result)))
 
+        (option '("recent-changes-limit") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'recent-changes-limit
+                              (string->number arg)
+                              (alist-delete 'recent-changes-limit result))))
+
         (option '("mirror") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'mirror
@@ -125,7 +132,8 @@
   '((port                                 . 8080)
     (host                                 . "0.0.0.0")
 
-    (storage-limit                        . "none")))
+    (storage-limit                        . "none")
+    (recent-changes-limit                 . 32768)))
 
 (define (parse-options options defaults args)
   (args-fold
@@ -276,6 +284,12 @@
                         "dumping database...\n")
          (dump-database database (assq-ref opts 'database-dump)))
 
+       (start-recent-change-removal-and-database-dump-thread
+        database
+        (assq-ref opts 'database-dump)
+        (* 24 3600)                     ; 24 hours
+        (assq-ref opts 'recent-changes-limit))
+
        (and=> (assq-ref opts 'mirror)
               (lambda (mirror)
                 (start-fetch-changes-thread database mirror)