diff options
| -rw-r--r-- | nar-herder/database.scm | 130 | ||||
| -rw-r--r-- | nar-herder/mirror.scm | 19 | ||||
| -rw-r--r-- | nar-herder/storage.scm | 30 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 50 |
4 files changed, 223 insertions, 6 deletions
diff --git a/nar-herder/database.scm b/nar-herder/database.scm index a1670ed..5d2ad1f 100644 --- a/nar-herder/database.scm +++ b/nar-herder/database.scm @@ -40,6 +40,7 @@ dump-database database-insert-narinfo + database-remove-narinfo database-select-narinfo-contents-by-hash database-select-recent-changes @@ -516,6 +517,135 @@ INSERT INTO narinfo_tags (narinfo_id, tag_id) VALUES (:narinfo_id, :tag_id)" narinfo-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 + db + " +DELETE FROM narinfos WHERE id = :id" + #:cache? #t))) + (sqlite-bind-arguments + statement + #:id id) + + (sqlite-step statement) + (sqlite-reset statement))) + + (define (remove-narinfo-files db narinfo-id) + (let ((statement + (sqlite-prepare + db + " +DELETE FROM narinfo_files WHERE narinfo_id = :narinfo_id" + #:cache? #t))) + (sqlite-bind-arguments + statement + #:narinfo_id narinfo-id) + + (sqlite-map (const #t) statement) + (sqlite-reset statement))) + + (define (remove-narinfo-references db narinfo-id) + (let ((statement + (sqlite-prepare + db + " +DELETE FROM narinfo_references WHERE narinfo_id = :narinfo_id" + #:cache? #t))) + (sqlite-bind-arguments + statement + #:narinfo_id narinfo-id) + + (sqlite-map (const #t) statement) + (sqlite-reset statement))) + + (define (insert-change db contents) + (let ((statement + (sqlite-prepare + db + " +INSERT INTO recent_changes ( + datetime, change, data +) VALUES ( + datetime('now'), 'removal', :store_path +)" + #:cache? #t))) + (sqlite-bind-arguments + statement + #:store_path store-path) + + (sqlite-step statement) + (sqlite-reset statement))) + + (define (insert-change-with-datetime db store-path datetime) + (let ((statement + (sqlite-prepare + db + " +INSERT INTO recent_changes ( + datetime, change, data +) VALUES ( + :datetime, 'removal', :store_path +)" + #:cache? #t))) + (sqlite-bind-arguments + statement + #:store_path store-path + #:datetime datetime) + + (sqlite-step statement) + (sqlite-reset statement))) + + (define (remove-tags db narinfo-id) + (let ((statement + (sqlite-prepare + db + " +DELETE FROM narinfo_tags WHERE narinfo_id = :narinfo_id" + #:cache? #t))) + + (sqlite-bind-arguments + statement + #:narinfo_id narinfo-id) + + (sqlite-map (const #t) statement) + (sqlite-reset statement))) + + (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)) + + (remove-narinfo-files db narinfo-id) + (remove-narinfo-references db narinfo-id) + (remove-tags db narinfo-id) + (remove-narinfo-record db narinfo-id) + + #t)))) + (define (database-select-narinfo-contents-by-hash database hash) (call-with-worker-thread (database-reader-thread-channel database) diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm index eddb349..6b9f4f7 100644 --- a/nar-herder/mirror.scm +++ b/nar-herder/mirror.scm @@ -30,6 +30,7 @@ #:use-module (logging logger) #:use-module (json) #:use-module (guix narinfo) + #:use-module ((guix store) #:select (store-path-hash-part)) #:use-module (nar-herder utils) #:use-module (nar-herder database) #:use-module (nar-herder storage) @@ -124,6 +125,24 @@ ;; checked, rather than ;; assumed to be false #:label-values '((stored . "false")))))) + ((string=? change "removal") + (let ((store-path (assq-ref change-details 'data))) + (log-msg 'INFO "processing removal change for " + store-path + " (" (assq-ref change-details 'datetime) ")") + + (when storage-root + (remove-nar-files-by-hash + database + storage-root + metrics-registry + (store-path-hash-part store-path))) + + (database-remove-narinfo database + store-path + #:change-datetime + (assq-ref change-details + 'datetime)))) (else (error "unimplemented")))))) recent-changes)) diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm index fab8966..386bacf 100644 --- a/nar-herder/storage.scm +++ b/nar-herder/storage.scm @@ -34,6 +34,7 @@ #:use-module (nar-herder utils) #:use-module (nar-herder database) #:export (store-item-in-local-storage? + remove-nar-files-by-hash get-nar-files @@ -51,6 +52,35 @@ (assq-ref file 'url))))) narinfo-files))) +(define (remove-nar-files-by-hash database storage-root metrics-registry + hash) + (define nar-files-metric + (or (metrics-registry-fetch-metric metrics-registry + "nar_files_total") + (make-gauge-metric metrics-registry + "nar_files_total" + #:labels '(stored)))) + + (let ((narinfo-files (database-select-narinfo-files database hash))) + (when (null? narinfo-files) + (error "no narinfo files")) + (for-each + (lambda (file) + (let* ((filename + (string-append storage-root + (uri-decode + (assq-ref file 'url)))) + (exists? + (file-exists? filename))) + (when exists? + (remove-nar-from-storage storage-root + (assq-ref file 'url))) + + (metric-decrement nar-files-metric + #:label-values + `((stored . ,(if exists? "true" "false")))))) + narinfo-files))) + (define (get-storage-size storage-root) (define enter? (const #t)) (define (leaf name stat result) diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index 165c0e4..37705bc 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -53,6 +53,7 @@ (guix progress) (guix narinfo) (guix derivations) + ((guix store) #:select (store-path-hash-part)) ((guix build utils) #:select (dump-port)) (nar-herder utils) (nar-herder database) @@ -74,7 +75,12 @@ (lambda (opt name arg result) (alist-cons 'database-dump arg - result))))) + result))) + (option '("storage") #t #f + (lambda (opt name arg result) + (alist-cons 'storage + arg + (alist-delete 'storage result)))))) (define %base-option-defaults ;; Alist of default option values @@ -111,11 +117,6 @@ (alist-cons 'pid-file arg (alist-delete 'pid-file result)))) - (option '("storage") #t #f - (lambda (opt name arg result) - (alist-cons 'storage - arg - (alist-delete 'storage result)))) (option '("storage-limit") #t #f (lambda (opt name arg result) (alist-cons 'storage-limit @@ -252,6 +253,43 @@ (report)) narinfos)))))) + (("remove" rest ...) + (let* ((opts (parse-options %base-options + %base-option-defaults + rest)) + (database (setup-database + (assq-ref opts 'database))) + (lgr (make <logger>)) + (port-log (make <port-log> + #:port (current-output-port) + #:formatter + (lambda (lvl time str) + (format #f "~a (~5a): ~a~%" + (strftime "%F %H:%M:%S" (localtime time)) + lvl + str))))) + + (add-handler! lgr port-log) + (open-log! lgr) + (set-default-logger! lgr) + + (for-each + (lambda (store-path) + (log-msg 'INFO "removing " store-path) + + ;; Removing the files here isn't ideal, since the servers + ;; metrics won't be updated until the next get-nar-files call, + ;; but it avoids extra complexity in trying to have the server + ;; delete the files. + (remove-nar-files-by-hash + database + (assq-ref opts 'storage) + (make-metrics-registry #:namespace + "narherder") + (store-path-hash-part store-path)) + + (database-remove-narinfo database store-path)) + (assq-ref opts 'arguments)))) (("run-server" rest ...) (simple-format (current-error-port) "locale is ~A\n" (check-locale!)) |