Correct the metric problems from introducing fold-nar-files

The metrics are now updated at the end.

1 files changed, 153 insertions, 103 deletions

diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm
index a4335c5..2c8fde3 100644
--- a/nar-herder/storage.scm
+++ b/nar-herder/storage.scm
@@ -201,13 +201,6 @@
 (define* (fold-nar-files database storage-root metrics-registry
                          proc init
                          #:key stored?)
-  (define nar-files-metric
-    (or (metrics-registry-fetch-metric metrics-registry
-                                       "nar_files_total")
-        (make-gauge-metric metrics-registry
-                           "nar_files_total"
-                           #:labels '(stored))))
-
   (define stored-files-count 0)
   (define not-stored-files-count 0)
 
@@ -233,14 +226,49 @@
                   result)))
           init)))
 
-    (metric-set nar-files-metric
-                stored-files-count
-                #:label-values '((stored . "true")))
-    (metric-set nar-files-metric
-                 not-stored-files-count
-                #:label-values '((stored . "false")))
+    (values result
+            `((stored     . ,stored-files-count)
+              (not-stored . ,not-stored-files-count)))))
+
+(define* (update-nar-files-metric metrics-registry
+                                  nar-file-counts
+                                  #:key fetched-count removed-count)
+  (define nar-files-metric
+    (or (metrics-registry-fetch-metric metrics-registry
+                                       "nar_files_total")
+        (make-gauge-metric metrics-registry
+                           "nar_files_total"
+                           #:labels '(stored))))
 
-    result))
+  ;; Set the values if the counts are known
+  (and=>
+   (assq-ref nar-file-counts 'stored)
+   (lambda (stored-count)
+     (metric-set nar-files-metric
+                 stored-count
+                 #:label-values '((stored . "true")))))
+  (and=>
+   (assq-ref nar-file-counts 'not-stored)
+   (lambda (not-stored-count)
+     (metric-set nar-files-metric
+                 not-stored-count
+                 #:label-values '((stored . "false")))))
+
+  ;; Then adjust by the fetched or removed counts
+  (when fetched-count
+    (metric-increment nar-files-metric
+                      #:by fetched-count
+                      #:label-values '((stored . "true")))
+    (metric-decrement nar-files-metric
+                      #:by fetched-count
+                      #:label-values '((stored . "false"))))
+  (when removed-count
+    (metric-decrement nar-files-metric
+                      #:by removed-count
+                      #:label-values '((stored . "true")))
+    (metric-increment nar-files-metric
+                      #:by removed-count
+                      #:label-values '((stored . "false")))))
 
 (define (check-storage database storage-root metrics-registry)
   (define files
@@ -420,32 +448,40 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
 
       ;; Look through items in local storage, check if the removal
       ;; criteria have been met, and if so, delete it
-      (fold-nar-files
-       database
-       storage-root
-       metrics-registry
-       (lambda (nar storage-size)
-         (if (and (> storage-size storage-limit)
-                  (nar-can-be-removed? nar))
-             (begin
-               (remove-nar-from-storage
-                storage-root
-                (uri-decode
-                 (assq-ref nar 'url)))
-
-               (metric-decrement nar-files-metric
-                                 #:label-values '((stored . "true")))
-               (metric-increment nar-files-metric
-                                 #:label-values '((stored . "false")))
-
-               (let ((storage-size-estimate
-                      (- storage-size
-                         (assq-ref nar 'size))))
-                 storage-size-estimate))
-             storage-size))
-       initial-storage-size
-       #:stored? #t))
-    (log-msg 'INFO "finished looking for nars to remove"))
+      (let ((result
+             nar-file-counts
+             (fold-nar-files
+              database
+              storage-root
+              metrics-registry
+              (lambda (nar result)
+                (match result
+                  ((storage-size . removed-count)
+                   (if (and (> storage-size storage-limit)
+                            (nar-can-be-removed? nar))
+                       (begin
+                         (remove-nar-from-storage
+                          storage-root
+                          (uri-decode
+                           (assq-ref nar 'url)))
+
+                         (let ((storage-size-estimate
+                                (- storage-size
+                                   (assq-ref nar 'size))))
+                           (cons storage-size-estimate
+                                 (+ removed-count 1))))
+                       (cons storage-size
+                             removed-count)))))
+              (cons initial-storage-size 0)
+              #:stored? #t)))
+
+        (match result
+          ((storage-size . removed-count)
+           (update-nar-files-metric metrics-registry
+                                    nar-file-counts
+                                    #:removed-count removed-count)))
+
+        (log-msg 'INFO "finished looking for nars to remove"))))
 
   (when (null? nar-removal-criteria)
     (error "must be some removal criteria"))
@@ -543,43 +579,51 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
     ;; If there's free space, then consider downloading missing nars
     (if (< initial-storage-size storage-limit)
 
-        (let ((storage-size
+        (let ((result
+               nar-file-counts
                (fold-nar-files
                 database
                 storage-root
                 metrics-registry
-                (lambda (file storage-size)
+                (lambda (file result)
                   (log-msg 'DEBUG "considering "
                            (assq-ref file 'url))
-                  (let ((file-bytes (assq-ref file 'size)))
-                    (if (or no-storage-limit?
-                            (< (+ storage-size file-bytes)
-                               storage-limit))
-                        (let ((success?
-                               (with-exception-handler
-                                   (lambda (exn)
-                                     (log-msg 'ERROR "failed to fetch "
-                                              (assq-ref file 'url)
-                                              ": " exn)
-                                     #f)
-                                 (lambda ()
-                                   (retry-on-error
+                  (match result
+                    ((storage-size . fetched-count)
+                     (let ((file-bytes (assq-ref file 'size)))
+                       (if (or no-storage-limit?
+                               (< (+ storage-size file-bytes)
+                                  storage-limit))
+                           (let ((success?
+                                  (with-exception-handler
+                                      (lambda (exn)
+                                        (log-msg 'ERROR "failed to fetch "
+                                                 (assq-ref file 'url)
+                                                 ": " exn)
+                                        #f)
                                     (lambda ()
-                                      (fetch-file (assq-ref file 'url)))
-                                    #:times 3
-                                    #:delay 5)
-                                   #t)
-                                 #:unwind? #t)))
-                          (if success?
-                              (+ storage-size file-bytes)
-                              storage-size))
-                        ;; This file won't fit, so try the next one
-                        storage-size)))
+                                      (retry-on-error
+                                       (lambda ()
+                                         (fetch-file (assq-ref file 'url)))
+                                       #:times 3
+                                       #:delay 5)
+                                      #t)
+                                    #:unwind? #t)))
+                             (if success?
+                                 (cons (+ storage-size file-bytes)
+                                       (1+ fetched-count))
+                                 result))
+                           ;; This file won't fit, so try the next one
+                           result)))))
                 initial-storage-size
                 #:stored? #f)))
 
-          (not (= storage-size initial-storage-size)))
-
+          (match result
+            ((storage-size . fetched-count)
+             (update-nar-files-metric metrics-registry
+                                      nar-file-counts
+                                      #:fetched-count fetched-count)
+             (> fetched-count 0))))
         #f))
 
   (define (fast-download-nars)
@@ -595,49 +639,55 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
                 (set-thread-name "fast download nars"))
               (const #t))
 
-            (let loop ((any-change? #f))
+            (let loop ((fetched-count 0))
               (match (get-message channel)
                 (('finished . reply)
-                 (put-message reply any-change?))
+                 (put-message reply fetched-count))
                 (url
                  (log-msg 'DEBUG "considering " url)
                  (loop
-                  (or
-                   any-change?
-                   (with-exception-handler
-                       (lambda (exn)
-                         (log-msg 'ERROR "failed to fetch " url ": " exn)
-                         #f)
-                     (lambda ()
-                       (retry-on-error
-                        (lambda ()
-                          (fetch-file url))
-                        #:times 3
-                        #:delay 5)
-                       #t)
-                     #:unwind? #t)))))))))
+                  (+ fetched-count
+                     (with-exception-handler
+                         (lambda (exn)
+                           (log-msg 'ERROR "failed to fetch " url ": " exn)
+                           0)
+                       (lambda ()
+                         (retry-on-error
+                          (lambda ()
+                            (fetch-file url))
+                          #:times 3
+                          #:delay 5)
+                         1)
+                       #:unwind? #t)))))))))
        (iota parallelism))
 
-      (fold-nar-files
-       database
-       storage-root
-       metrics-registry
-       (lambda (nar _)
-         (put-message channel
-                      (assq-ref nar 'url))
-         #f)
-       #f
-       #:stored? #f)
-
-      (let ((reply-channel (make-channel)))
-        (any
-         identity
-         (map
-          (lambda _
-            (put-message channel
-                         (cons 'finished reply-channel))
-            (get-message reply-channel))
-          (iota parallelism))))))
+      (let ((result
+             nar-file-counts
+             (fold-nar-files
+              database
+              storage-root
+              metrics-registry
+              (lambda (nar _)
+                (put-message channel
+                             (assq-ref nar 'url))
+                #f)
+              #f
+              #:stored? #f)))
+
+        (let* ((reply-channel (make-channel))
+               (fetched-count
+                (apply
+                 +
+                 (map
+                  (lambda _
+                    (put-message channel
+                                 (cons 'finished reply-channel))
+                    (get-message reply-channel))
+                  (iota parallelism)))))
+
+          (update-nar-files-metric metrics-registry
+                                   nar-file-counts
+                                   #:fetched-count fetched-count)))))
 
   (define (run-mirror-pass)
     (log-msg 'DEBUG "running mirror pass")