From ad9452e63a0a60f79146efd714f081b6c898449e Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 6 May 2022 14:16:54 +0100
Subject: Support removing nar files

---
 scripts/nar-herder.in | 50 ++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 44 insertions(+), 6 deletions(-)

(limited to 'scripts')

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!))
 
-- 
cgit v1.2.3