Finish an initial implementation of pruning the cached nars

2 files changed, 113 insertions, 16 deletions

diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm
index d82a9e2..2711154 100644
--- a/nar-herder/cached-compression.scm
+++ b/nar-herder/cached-compression.scm
@@ -156,25 +156,100 @@
                                                  (assq-ref details 'compression))))
          database-entries-missing-files)))
 
-    ;; Remove cached files if the max size is exceeded
-    (for-each
-     (match-lambda
-       ((compression . cached-bytes)
-        (maybe-remove-cached-files-for-compression
-         database
-         enabled-cached-compressions
-         compression
-         cached-bytes-by-compression)))
-     cached-bytes-by-compression)
-
     cached-bytes-by-compression))
 
 (define (maybe-remove-cached-files-for-compression database
                                                    enabled-cached-compressions
                                                    compression
-                                                   cached-bytes-by-compression)
-  ;; TODO Implement
-  #f)
+                                                   cached-bytes-by-compression-box
+                                                   nar-cache-bytes-metric)
+  (let* ((compression-details
+          (assq-ref enabled-cached-compressions
+                    compression))
+         (max-size
+          (assq-ref compression-details
+                    'directory-max-size)))
+    (when max-size
+      (let ((current-size
+             (assq-ref
+              (atomic-box-ref cached-bytes-by-compression-box)
+              compression)))
+        (when (> current-size max-size)
+          (let ((bytes-to-remove
+                 (- current-size max-size)))
+            (log-msg 'DEBUG
+                     "looking to remove " bytes-to-remove " bytes of "
+                     compression " compressed nars")
+
+            (match
+                (database-fold-cached-narinfo-files
+                 database
+                 (match-lambda*
+                   ((details (finished? bytes result))
+                    (if finished?
+                        (list finished? bytes result)
+                        (if (eq? (assq-ref details 'compression)
+                                 compression)
+                            (let ((new-bytes
+                                   (+ bytes
+                                      (assq-ref details 'size))))
+                              (cons
+                               ;; finished if enough bytes are going
+                               ;; to be removed
+                               (> new-bytes bytes-to-remove)
+                               (list new-bytes (cons details result))))
+                            (list #f bytes result)))))
+                 '(#f 0 ()))
+              ((#t bytes-for-removal files-to-remove-details)
+               (log-msg 'DEBUG "removing " (length files-to-remove-details)
+                        " " compression " compressed nars from the cache")
+
+               ;; Remove all the database entries first, as that'll
+               ;; stop these files appearing in narinfos
+               (for-each
+                (lambda (details)
+                  (database-remove-cached-narinfo-file
+                   database
+                   (assq-ref details 'narinfo-id)
+                   (symbol->string compression)))
+                files-to-remove-details)
+
+               (let ((directory
+                      (assq-ref compression-details 'directory)))
+                 (for-each
+                  (lambda (details)
+                    (let ((filename
+                           (string-append
+                            directory "/"
+                            (basename (assq-ref details 'store-path)))))
+                      (log-msg 'DEBUG "deleting " filename)
+                      (delete-file filename)))
+                  files-to-remove-details)
+
+                 (let* ((cached-bytes-by-compression
+                         (atomic-box-ref cached-bytes-by-compression-box))
+                        (new-cached-bytes
+                         (- (assq-ref cached-bytes-by-compression
+                                      compression)
+                            bytes-for-removal)))
+                   (atomic-box-set!
+                    cached-bytes-by-compression-box
+                    (alist-cons
+                     compression
+                     new-cached-bytes
+                     (alist-delete
+                      compression
+                      cached-bytes-by-compression)))
+
+                   (metric-set
+                    nar-cache-bytes-metric
+                    new-cached-bytes
+                    #:label-values `((compression . ,compression)))
+
+                   (log-msg 'DEBUG "finished removing " bytes-for-removal
+                            " bytes of " compression
+                            " cached nars from " directory
+                            " (new size " new-cached-bytes ")")))))))))))
 
 (define* (make-maybe-trigger-creation-of-compressed-nars
           database
@@ -208,6 +283,18 @@
                    #:label-values `((compression . ,compression)))))
                (atomic-box-ref cached-bytes-by-compression-box))
 
+              ;; Remove cached files if the max size is exceeded
+              (for-each
+               (match-lambda
+                 ((compression . _)
+                  (maybe-remove-cached-files-for-compression
+                   database
+                   enabled-cached-compressions
+                   compression
+                   cached-bytes-by-compression-box
+                   nar-cache-bytes-metric)))
+               (atomic-box-ref cached-bytes-by-compression-box))
+
               (list cached-bytes-by-compression-box)))
           ;; Just make one thread, as this thread won't do much work
           ;; and relies on a hash table that shouldn't be accessed by
@@ -296,7 +383,8 @@
                        database
                        enabled-cached-compressions
                        missing-compression
-                       cached-bytes-by-compression)))))
+                       cached-bytes-by-compression-box
+                       nar-cache-bytes-metric)))))
                missing-compressions)
 
               (with-usage-hash-table
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index 829b23a..2e2563c 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -461,6 +461,12 @@
                      (match-lambda
                        (('cached-compression-directory . details) details)
                        (_ #f))
+                     opts))
+                   (cached-compression-directories-max-sizes
+                    (filter-map
+                     (match-lambda
+                       (('cached-compression-directory-max-size . details) details)
+                       (_ #f))
                      opts)))
                (filter-map
                 (match-lambda
@@ -473,7 +479,10 @@
                               . ,(or (assq-ref explicit-cached-compression-directories
                                                compression)
                                      (simple-format #f "/var/cache/nar-herder/nar/~A"
-                                                    compression)))))))
+                                                    compression)))
+                             (directory-max-size
+                              . ,(assq-ref cached-compression-directories-max-sizes
+                                           compression))))))
                   (_ #f))
                 opts)))