diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | nar-herder/database.scm | 58 | ||||
| -rw-r--r-- | nar-herder/recent-changes.scm | 63 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 16 |
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) |