diff options
| -rw-r--r-- | nar-herder/storage.scm | 36 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 44 |
2 files changed, 80 insertions, 0 deletions
diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm index 52c218b..f055e2e 100644 --- a/nar-herder/storage.scm +++ b/nar-herder/storage.scm @@ -31,6 +31,7 @@ #:use-module (json) #:use-module ((guix build utils) #:select (dump-port mkdir-p)) #:use-module ((guix store) #:select (store-path-hash-part)) + #:use-module (guix progress) #:use-module (nar-herder utils) #:use-module (nar-herder database) #:export (store-item-in-local-storage? @@ -38,6 +39,8 @@ get-nar-files + check-storage + start-nar-removal-thread start-mirroring-thread)) @@ -189,6 +192,39 @@ selected-files)) +(define (check-storage database storage-root metrics-registry) + (define files + (get-nar-files database storage-root metrics-registry + #:stored? #t)) + + (define files-count + (length files)) + + (call-with-progress-reporter + (progress-reporter/bar files-count + (simple-format #f "checking ~A files" files-count) + (current-error-port)) + (lambda (report) + (fold + (lambda (file result) + (let* ((full-filename + (string-append storage-root + (assq-ref file 'url))) + (file-size + (stat:size (stat full-filename))) + (database-size + (assq-ref file 'size))) + (report) + (if (not (= file-size database-size)) + (begin + (newline) + (log-msg 'WARN "file " full-filename + " has inconsistent size (database: " + database-size ", file: " file-size ")")) + #f))) + '() + files)))) + (define (start-nar-removal-thread database storage-root storage-limit metrics-registry diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index 19ed332..1493d0b 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -247,6 +247,12 @@ (recent-changes-limit . 32768))) +(define %check-options + (list)) + +(define %check-option-defaults + '()) + (define (parse-options options defaults args) (args-fold args options @@ -359,6 +365,44 @@ (database-remove-narinfo database store-path)) (assq-ref opts 'arguments)))) + (("check" rest ...) + (let* ((opts (parse-options (append %base-options + %check-options) + (append %base-option-defaults + %check-option-defaults) + rest)) + (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)))) + (metrics-registry (make-metrics-registry + #:namespace + "narherder"))) + + (add-handler! lgr port-log) + (open-log! lgr) + (set-default-logger! lgr) + + (let ((log-level (assq-ref opts 'log-level))) + (let loop ((levels %valid-log-levels)) + (when (and (not (null? levels)) + (not (eq? (car levels) log-level))) + (disable-log-level! lgr (car levels)) + (loop (cdr levels))))) + + (let* ((database (setup-database (assq-ref opts 'database) + metrics-registry)) + (canonical-storage (and=> (assq-ref opts 'storage) + canonicalize-path))) + + (check-storage database + canonical-storage + metrics-registry)))) (("run-server" rest ...) (simple-format (current-error-port) "locale is ~A\n" (check-locale!)) |