diff options
| -rw-r--r-- | nar-herder/server.scm | 1 | ||||
| -rw-r--r-- | nar-herder/storage.scm | 52 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 7 |
3 files changed, 46 insertions, 14 deletions
diff --git a/nar-herder/server.scm b/nar-herder/server.scm index bedfd17..97f0567 100644 --- a/nar-herder/server.scm +++ b/nar-herder/server.scm @@ -805,6 +805,7 @@ (start-mirroring-fiber database (assq-ref opts 'mirror) (assq-ref opts 'storage-limit) + (assq-ref opts 'minimum-free-space) canonical-storage metrics-registry))) (removal-channel diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm index 80c6b1d..b57ccd8 100644 --- a/nar-herder/storage.scm +++ b/nar-herder/storage.scm @@ -33,6 +33,7 @@ #:use-module (prometheus) #:use-module (json) #:use-module ((guix build utils) #:select (dump-port mkdir-p)) + #:use-module ((guix build syscalls) #:select (free-disk-space)) #:use-module ((guix store) #:select (store-path-hash-part)) #:use-module (guix progress) #:use-module (nar-herder utils) @@ -565,11 +566,14 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." removal-channel) -(define (start-mirroring-fiber database mirror storage-limit storage-root - metrics-registry) +(define (start-mirroring-fiber database mirror storage-limit minimum-free-space + storage-root metrics-registry) - (define no-storage-limit? - (not (integer? storage-limit))) + (define storage-limit? + (integer? storage-limit)) + + (define minimum-free-space? + (integer? minimum-free-space)) (define storage-size-metric (or (metrics-registry-fetch-metric metrics-registry @@ -577,6 +581,12 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (make-gauge-metric metrics-registry "storage_size_bytes"))) + (define storage-free-space-metric + (or (metrics-registry-fetch-metric metrics-registry + "storage_free_space_bytes") + (make-gauge-metric metrics-registry + "storage_free_space_bytes"))) + (define (fetch-file file) (let* ((string-url (string-append mirror file)) @@ -632,9 +642,19 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." '() #:fetched-count 1))) - (define (download-nars initial-storage-size) - ;; If there's free space, then consider downloading missing nars - (if (< initial-storage-size storage-limit) + (define (download-nars initial-storage-size initial-free-space) + (define effective-storage-limit + (cond + ((and storage-limit? minimum-free-space?) + (min storage-limit + (+ initial-storage-size + (- initial-free-space minimum-free-space)))) + (storage-limit? storage-limit) + (minimum-free-space? + (+ initial-storage-size + (- initial-free-space minimum-free-space))))) + + (if (< initial-storage-size effective-storage-limit) (let ((result nar-file-counts (fold-nar-files @@ -646,9 +666,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (match result ((storage-size . fetched-count) (let ((file-bytes (assq-ref file 'size))) - (if (or no-storage-limit? - (< (+ storage-size file-bytes) - storage-limit)) + (if (< (+ storage-size file-bytes) + effective-storage-limit) (let ((success? (with-exception-handler (lambda (exn) @@ -739,13 +758,18 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (define (run-mirror-pass) (log-msg 'DEBUG "running mirror pass") (let ((initial-storage-size (with-time-logging "getting storage size" - (get-storage-size storage-root)))) + (get-storage-size storage-root))) + (free-space + (free-disk-space storage-root))) (metric-set storage-size-metric initial-storage-size) + (metric-set storage-free-space-metric + free-space) (let ((fetched-count - (if no-storage-limit? - (fast-download-nars) - (download-nars initial-storage-size)))) + (if (or storage-limit? minimum-free-space?) + (download-nars initial-storage-size + free-space) + (fast-download-nars)))) (log-msg 'DEBUG "finished mirror pass (fetched " fetched-count " nars)")))) (let ((channel (make-channel))) diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index a0e3127..a611018 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -148,6 +148,13 @@ "none" (string->number arg)) (alist-delete 'storage-limit result)))) + (option '("storage-minimum-free-space") #t #f + (lambda (opt name arg result) + (alist-cons 'storage-minimum-free-space + (if (string=? arg "none") + "none" + (string->number arg)) + (alist-delete 'storage-minimum-free-space result)))) ;; (stored-on https://other-nar-herder-server) ;; and=((stored-on https://other-nar-herder-server) (stored-on https://different-server)) |