aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--nar-herder/storage.scm36
-rw-r--r--scripts/nar-herder.in44
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!))