diff options
| -rw-r--r-- | nar-herder/mirror.scm | 14 | ||||
| -rw-r--r-- | nar-herder/storage.scm | 30 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 83 |
3 files changed, 64 insertions, 63 deletions
diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm index ab46bf0..a87b898 100644 --- a/nar-herder/mirror.scm +++ b/nar-herder/mirror.scm @@ -30,6 +30,7 @@ #:use-module (prometheus) #:use-module (logging logger) #:use-module (json) + #:use-module (fibers) #:use-module (guix narinfo) #:use-module ((guix build syscalls) #:select (set-thread-name)) @@ -37,10 +38,10 @@ #:use-module (nar-herder utils) #:use-module (nar-herder database) #:use-module (nar-herder storage) - #:export (start-fetch-changes-thread)) + #:export (start-fetch-changes-fiber)) -(define (start-fetch-changes-thread database storage-root - mirror metrics-registry) +(define (start-fetch-changes-fiber database storage-root + mirror metrics-registry) (define nar-files-metric (or (metrics-registry-fetch-metric metrics-registry "nar_files_total") @@ -165,13 +166,8 @@ (response-code response) (utf8->string body)))))))) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "nh fetch changes")) - (const #t)) - ;; This will initialise the nar_files_total metric (get-nar-files database storage-root metrics-registry) diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm index 2c8fde3..8c1fd78 100644 --- a/nar-herder/storage.scm +++ b/nar-herder/storage.scm @@ -45,8 +45,8 @@ check-storage - start-nar-removal-thread - start-mirroring-thread)) + start-nar-removal-fiber + start-mirroring-fiber)) (define (store-item-in-local-storage? database storage-root hash) (let ((narinfo-files (database-select-narinfo-files database hash))) @@ -376,10 +376,10 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (proc (open-socket-for-uri/cached uri))) #:unwind? #t)) -(define (start-nar-removal-thread database - storage-root storage-limit - metrics-registry - nar-removal-criteria) +(define (start-nar-removal-fiber database + storage-root storage-limit + metrics-registry + nar-removal-criteria) (define storage-size-metric (make-gauge-metric metrics-registry "storage_size_bytes")) @@ -486,13 +486,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (when (null? nar-removal-criteria) (error "must be some removal criteria")) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "nh remove")) - (const #t)) - (while #t (with-exception-handler (lambda (exn) @@ -502,8 +497,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (sleep 300))))) -(define (start-mirroring-thread database mirror storage-limit storage-root - metrics-registry) +(define (start-mirroring-fiber database mirror storage-limit storage-root + metrics-registry) (define no-storage-limit? (not (integer? storage-limit))) @@ -702,13 +697,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (log-msg 'DEBUG "finished mirror pass (any change? " any-change? ")") any-change?))) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "nh mirror")) - (const #t)) - (while #t (unless (with-exception-handler (lambda (exn) diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index 59df42e..ac3002b 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -39,6 +39,7 @@ (ice-9 ftw) (ice-9 match) (ice-9 format) + (ice-9 threads) (ice-9 suspendable-ports) (web uri) (web client) @@ -57,6 +58,7 @@ (guix derivations) ((guix store) #:select (store-path-hash-part)) ((guix build utils) #:select (dump-port)) + ((guix build syscalls) #:select (set-thread-name)) (nar-herder utils) (nar-herder database) (nar-herder recent-changes) @@ -614,46 +616,59 @@ (* 24 3600) ; 24 hours (assq-ref opts 'recent-changes-limit)) - (and=> (assq-ref opts 'mirror) - (lambda (mirror) - (start-fetch-changes-thread database + (let ((finished? (make-condition))) + (call-with-new-thread + (lambda () + (catch 'system-error + (lambda () + (set-thread-name "maintenance")) + (const #t)) + + (run-fibers + (lambda () + (and=> (assq-ref opts 'mirror) + (lambda (mirror) + (start-fetch-changes-fiber database + canonical-storage + mirror + metrics-registry) + + (when (assq-ref opts 'storage) + (start-mirroring-fiber database + mirror + (assq-ref opts 'storage-limit) + canonical-storage + metrics-registry)))) + + + (let ((nar-removal-criteria + (filter-map + (match-lambda + ((key . val) + (if (eq? key 'storage-nar-removal-criteria) + val + #f))) + opts))) + (when (and (assq-ref opts 'storage) + (number? (assq-ref opts 'storage-limit)) + (not (null? nar-removal-criteria))) + (start-nar-removal-fiber database canonical-storage - mirror - metrics-registry) - - (when (assq-ref opts 'storage) - (start-mirroring-thread database - mirror - (assq-ref opts 'storage-limit) - canonical-storage - metrics-registry)))) - - - (let ((nar-removal-criteria - (filter-map - (match-lambda - ((key . val) - (if (eq? key 'storage-nar-removal-criteria) - val - #f))) - opts))) - (when (and (assq-ref opts 'storage) - (number? (assq-ref opts 'storage-limit)) - (not (null? nar-removal-criteria))) - (start-nar-removal-thread database - canonical-storage - (assq-ref opts 'storage-limit) - metrics-registry - nar-removal-criteria))) - - (log-msg 'INFO "starting server, listening on " - (assq-ref opts 'host) ":" (assq-ref opts 'port)) + (assq-ref opts 'storage-limit) + metrics-registry + nar-removal-criteria))) + + (wait finished?)) + #:hz 0 + #:parallelism 1))) - (let ((finished? (make-condition))) (call-with-sigint (lambda () (run-fibers (lambda () + (log-msg 'INFO "starting server, listening on " + (assq-ref opts 'host) ":" (assq-ref opts 'port)) + (run-server/patched (make-request-handler database canonical-storage |