Add some basic functionality to check the size of the stored files

1 files changed, 44 insertions, 0 deletions

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!))