diff options
| -rw-r--r-- | nar-herder/database.scm | 12 | ||||
| -rw-r--r-- | nar-herder/mirror.scm | 35 | ||||
| -rw-r--r-- | nar-herder/server.scm | 10 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 59 |
4 files changed, 81 insertions, 35 deletions
diff --git a/nar-herder/database.scm b/nar-herder/database.scm index 98c29d5..666c497 100644 --- a/nar-herder/database.scm +++ b/nar-herder/database.scm @@ -63,6 +63,7 @@ database-insert-cached-narinfo-file database-select-cached-narinfo-file-by-hash + database-select-cached-narinfo-file-by-narinfo-id-and-compression database-select-cached-narinfo-files-by-narinfo-id database-fold-cached-narinfo-files database-remove-cached-narinfo-file @@ -855,17 +856,6 @@ DELETE FROM narinfo_tags WHERE narinfo_id = :narinfo_id" (remove-narinfo-references db narinfo-id) (remove-tags db narinfo-id) - (for-each - (lambda (cached-details) - (database-remove-cached-narinfo-file - database - narinfo-id - (symbol->string - (assq-ref cached-details 'compression)))) - (database-select-cached-narinfo-files-by-narinfo-id - database - narinfo-id)) - (remove-narinfo-record db narinfo-id) #t) #f))))) diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm index 47ae549..a784165 100644 --- a/nar-herder/mirror.scm +++ b/nar-herder/mirror.scm @@ -31,6 +31,7 @@ #:use-module (logging logger) #:use-module (json) #:use-module (fibers) + #:use-module (fibers channels) #:use-module (guix narinfo) #:use-module ((guix store) #:select (store-path-hash-part)) #:use-module (nar-herder utils) @@ -38,8 +39,9 @@ #:use-module (nar-herder storage) #:export (start-fetch-changes-fiber)) -(define (start-fetch-changes-fiber database storage-root - mirror metrics-registry) +(define (start-fetch-changes-fiber database metrics-registry + storage-root mirror + cached-compression-management-channel) (define (request-recent-changes) (define latest-recent-change (database-select-latest-recent-change-datetime database)) @@ -141,18 +143,43 @@ store-path " (" (assq-ref change-details 'datetime) ")") + (let* ((hash (store-path-hash-part store-path)) + (narinfo-details + (database-select-narinfo-by-hash + database + hash))) + (when storage-root (remove-nar-files-by-hash database storage-root metrics-registry - (store-path-hash-part store-path))) + hash)) + + (let ((cached-narinfo-files + (database-select-cached-narinfo-files-by-narinfo-id + database + (assq-ref narinfo-details 'id)))) + (for-each + (lambda (cached-narinfo-file-details) + ;; TODO Delete the file as well + + (let ((reply (make-channel))) + (put-message + cached-compression-management-channel + (list 'cached-narinfo-removed + (assq-ref narinfo-details 'id) + (assq-ref cached-narinfo-files 'compression) + (assq-ref cached-narinfo-files 'size) + reply)) + (get-message reply))) + cached-narinfo-files)) (database-remove-narinfo database store-path #:change-datetime (assq-ref change-details - 'datetime)))) + 'datetime))))) (else (error "unimplemented")))))) recent-changes)) diff --git a/nar-herder/server.scm b/nar-herder/server.scm index 583b4a3..6d9d553 100644 --- a/nar-herder/server.scm +++ b/nar-herder/server.scm @@ -768,10 +768,12 @@ (and=> (assq-ref opts 'mirror) (lambda (mirror) - (start-fetch-changes-fiber database - canonical-storage - mirror - metrics-registry) + (start-fetch-changes-fiber + database + metrics-registry + canonical-storage + mirror + cached-compression-management-channel) (if (assq-ref opts 'storage) (start-mirroring-fiber database diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index e4ce9c2..7e5b35f 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -452,22 +452,49 @@ (for-each (lambda (store-path) - (log-msg 'INFO "removing " store-path) - - (if (assq-ref opts 'storage) - (begin - (remove-nar-files-by-hash - database - (assq-ref opts 'storage) - metrics-registry - (store-path-hash-part store-path) - #:error-unless-files-to-remove? #f)) - (log-msg - 'WARN "no --storage set, so just removing from the database")) - - (let ((removed? (database-remove-narinfo database store-path))) - (unless removed? - (log-msg 'WARN store-path " not found to remove")))) + (let ((narinfo-details + (database-select-narinfo-by-hash + database + (store-path-hash-part store-path)))) + + (if narinfo-details + (let ((cached-narinfo-files + (database-select-cached-narinfo-files-by-narinfo-id + database + (assq-ref narinfo-details 'id)))) + + (log-msg 'INFO "removing " store-path) + + (if (assq-ref opts 'storage) + (begin + (remove-nar-files-by-hash + database + (assq-ref opts 'storage) + metrics-registry + (store-path-hash-part store-path) + #:error-unless-files-to-remove? #f)) + (log-msg + 'WARN "no --storage set, so just removing from the database")) + + (for-each + (lambda (cached-narinfo-details) + ;; It might not have been scheduled for + ;; removal, but remove any schedule that + ;; exists + (database-delete-scheduled-cached-narinfo-removal + database + (assq-ref cached-narinfo-details 'id)) + + ;; Remove all the database entries first, as + ;; that'll stop these files appearing in narinfos + (database-remove-cached-narinfo-file + database + narinfo-id + (symbol->string compression))) + cached-narinfo-files) + + (database-remove-narinfo database store-path)) + (log-msg 'WARN store-path " not found to remove")))) (assq-ref opts 'arguments)))) (("check" rest ...) (let* ((opts (parse-options (append %base-options |