diff options
Diffstat (limited to 'scripts/nar-herder.in')
| -rw-r--r-- | scripts/nar-herder.in | 476 |
1 files changed, 320 insertions, 156 deletions
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index d1f95d1..fafcf9f 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -22,6 +22,11 @@ ;;; along with the guix-data-service. If not, see ;;; <http://www.gnu.org/licenses/>. +(when (and (string-prefix? "aarch64-" %host-type) + (not (getenv "GUILE_JIT_THRESHOLD"))) + (setenv "GUILE_JIT_THRESHOLD" "-1") + (apply execlp (car (command-line)) (command-line))) + (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) @@ -36,9 +41,12 @@ (srfi srfi-19) (srfi srfi-37) (srfi srfi-43) + (srfi srfi-71) (ice-9 ftw) (ice-9 match) (ice-9 format) + (ice-9 threads) + (ice-9 suspendable-ports) (web uri) (web client) (web response) @@ -47,21 +55,20 @@ (logging port-log) (prometheus) (fibers) - (fibers conditions) - (fibers web server) ((guix ui) #:select (read/eval string->duration)) - (guix progress) + (guix store) (guix narinfo) + (guix progress) (guix derivations) ((guix store) #:select (store-path-hash-part)) ((guix build utils) #:select (dump-port)) (nar-herder utils) (nar-herder database) - (nar-herder recent-changes) (nar-herder storage) - (nar-herder mirror) (nar-herder server)) +(install-suspendable-ports!) + (define %valid-log-levels '(DEBUG INFO WARN ERROR)) @@ -80,12 +87,26 @@ (lambda (opt name arg result) (alist-cons 'storage arg - (alist-delete 'storage result)))))) + (alist-delete 'storage result)))) + + (option '("log-level") #t #f + (lambda (opt name arg result) + (alist-cons 'log-level + (let ((level (string->symbol (string-upcase arg)))) + (if (member level %valid-log-levels) + level + (error + (simple-format #f "unknown log level ~A\nvalid levels are: ~A\n" + level + %valid-log-levels)))) + (alist-delete 'log-level result)))))) (define %base-option-defaults ;; Alist of default option values `((database . ,(string-append (getcwd) "/nar_herder.db")) - (database-dump . ,(string-append (getcwd) "/nar_herder_dump.db")))) + (database-dump . ,(string-append (getcwd) "/nar_herder_dump.db")) + + (log-level . DEBUG))) (define %import-options (list (option '("tag") #t #f @@ -96,7 +117,10 @@ (cons key value))) (or (assq-ref result 'tags) '())) - (alist-delete 'tags result)))))) + (alist-delete 'tags result)))) + (option '("ensure-references-exist") #f #f + (lambda (opt name _ result) + (alist-cons 'ensure-references-exist #t result))))) (define %import-options-defaults '()) @@ -136,6 +160,111 @@ (call-with-input-string rest read)))) result))) + (option '("enable-cached-compression") #t #f + (lambda (opt name arg result) + (alist-cons 'cached-compression + (match (string-split arg #\:) + ((type) + `((type . ,(string->symbol type)))) + ((type level) + `((type . ,(string->symbol type)) + (level . ,(string->number level))))) + result))) + + (option '("cached-compression-directory") #t #f + (lambda (opt name arg result) + (alist-cons 'cached-compression-directory + (match (string-split arg #\=) + ((type directory) + (cons (string->symbol type) + (canonicalize-path directory)))) + result))) + + (option '("cached-compression-directory-max-size") #t #f + (lambda (opt name arg result) + (alist-cons 'cached-compression-directory-max-size + (match (string-split arg #\=) + ((type size) + (cons (string->symbol type) + (string->number size)))) + result))) + + (option '("cached-compression-min-uses") #t #f + (lambda (opt name arg result) + (alist-cons 'cached-compression-min-uses + (string->number arg) + (alist-delete 'cached-compression-min-uses + result)))) + + (option '("cached-compression-workers") #t #f + (lambda (opt name arg result) + (alist-cons 'cached-compression-workers + (string->number arg) + result))) + + (option '("cached-compression-nar-source") #t #f + (lambda (opt name arg result) + (alist-cons 'cached-compression-nar-source + arg + (alist-delete 'cached-compression-nar-source + result)))) + (option '("cached-compression-unused-removal-duration") #t #f + (lambda (opt name arg result) + (alist-cons + 'cached-compression-unused-removal-duration + (match (string-split arg #\=) + ((_) + (simple-format + (current-error-port) + "cached-compressions-unused-removal-duration: you must specify compression and value\n") + (exit 1)) + ((type duration-string) + (cons (string->symbol type) + (let ((duration (string->duration duration-string))) + (unless duration + (simple-format + (current-error-port) + "~A: cached-compressions-unused-removal-duration: invalid duration\n" + arg) + (exit 1)) + + duration)))) + result))) + (option '("cached-compressions-ttl") #t #f + (lambda (opt name arg result) + (alist-cons 'cached-compression-ttl + (match (string-split arg #\=) + ((_) + (simple-format + (current-error-port) + "cached-compressions-ttl: you must specify compression and value\n") + (exit 1)) + ((type ttl-string) + (let ((duration (string->duration ttl-string))) + (unless duration + (simple-format (current-error-port) + "~A: invalid duration\n" + arg) + (exit 1)) + + (cons (string->symbol type) + (time-second duration))))) + result))) + (option '("cached-compressions-new-ttl") #t #f + (lambda (opt name arg result) + (let ((duration (string->duration arg))) + (unless duration + (simple-format (current-error-port) + "~A: invalid duration\n" + arg) + (exit 1)) + (alist-cons 'cached-compression-new-ttl + (match (string-split arg #\=) + ((type size) + (cons (string->symbol type) + (time-second duration)))) + result)))) + (option '("ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) @@ -146,6 +275,16 @@ (exit 1)) (alist-cons 'narinfo-ttl (time-second duration) result)))) + (option '("new-ttl") #t #f + (lambda (opt name arg result) + (let ((duration (string->duration arg))) + (unless duration + (simple-format (current-error-port) + "~A: invalid duration\n" + arg) + (exit 1)) + (alist-cons 'new-narinfo-ttl (time-second duration) + result)))) (option '("negative-ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) @@ -169,26 +308,40 @@ arg (alist-delete 'mirror result)))) - (option '("log-level") #t #f + (option '("parallelism") #t #f (lambda (opt name arg result) - (alist-cons 'log-level - (let ((level (string->symbol (string-upcase arg)))) - (if (member level %valid-log-levels) - level - (error - (simple-format #f "unknown log level ~A\nvalid levels are: ~A\n" - level - %valid-log-levels)))) - (alist-delete 'log-level result)))))) + (alist-cons 'parallelism + (string->number arg) + (alist-delete 'parallelism result)))) + + (option '("database-reader-threads") #t #f + (lambda (opt name arg result) + (alist-cons 'database-reader-threads + (string->number arg) + (alist-delete 'database-reader-threads result)))))) (define %server-option-defaults - '((port . 8080) + `((port . 8080) (host . "0.0.0.0") - (log-level . DEBUG) - (storage-limit . "none") - (recent-changes-limit . 32768))) + + (cached-compression-workers . 2) + (cached-compression-min-uses . 3) + + (recent-changes-limit . 32768) + + (database-reader-threads . ,(min (max (current-processor-count) + 2) + 64)) + + (parallelism . 1))) + +(define %check-options + (list)) + +(define %check-option-defaults + '()) (define (parse-options options defaults args) (args-fold @@ -245,19 +398,52 @@ (call-with-progress-reporter progress (lambda (report) - (for-each (lambda (narinfo) - (database-insert-narinfo - database - (call-with-input-file narinfo - (lambda (port) - ;; Set url to a dummy value as this doesn't - ;; matter - (read-narinfo port "https://narherderdummyvalue"))) - #:tags (or (assq-ref opts 'tags) - '())) - - (report)) - narinfos)))))) + (database-call-with-transaction + database + (lambda (db) + (let ((read-narinfos + (map + (lambda (narinfo-file) + (let ((narinfo + (call-with-input-file narinfo-file + (lambda (port) + ;; Set url to a dummy value as this doesn't + ;; matter + (read-narinfo port + "https://narherderdummyvalue"))))) + + (database-insert-narinfo + database + narinfo + #:tags (or (assq-ref opts 'tags) + '())) + + (report) + + narinfo)) + narinfos))) + + (when (assq-ref opts 'ensure-references-exist) + (for-each + (lambda (narinfo) + (let ((self-reference + (store-path-base + (narinfo-path narinfo)))) + (for-each + (lambda (reference) + (when (and + (not + (string=? reference self-reference)) + (not + (database-select-narinfo-by-hash + database + (string-take reference 32)))) + (error + (simple-format (current-error-port) + "missing reference to ~A\n" + reference)))) + (narinfo-references narinfo)))) + read-narinfos)))))))))) (("remove" rest ...) (let* ((opts (parse-options %base-options %base-option-defaults @@ -272,11 +458,14 @@ (port-log (make <port-log> #:port (current-output-port) #:formatter - (lambda (lvl time str) + ;; In guile-lib v0.2.8 onwards, the formatter is + ;; called with more arguments + (lambda args ; lvl, time, str (format #f "~a (~5a): ~a~%" - (strftime "%F %H:%M:%S" (localtime time)) - lvl - str))))) + (strftime "%F %H:%M:%S" (localtime + (second args))) + (first args) + (third args)))))) (add-handler! lgr port-log) (open-log! lgr) @@ -284,24 +473,91 @@ (for-each (lambda (store-path) - (log-msg 'INFO "removing " store-path) - - (if (assq-ref opts 'storage) - (begin - ;; 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) - metrics-registry - (store-path-hash-part store-path))) - (log-msg - 'WARN "no --storage set, so just removing from the database")) - - (database-remove-narinfo database store-path)) + (let ((narinfo-details + (database-select-narinfo-by-hash + database + (store-path-hash-part store-path)))) + + (if narinfo-details + (let ((cached-narinfo-files + (database-select-cached-narinfo-files-by-narinfo-id + database + (assq-ref narinfo-details 'id)))) + + (log-msg 'INFO "removing " store-path) + + (if (assq-ref opts 'storage) + (begin + (remove-nar-files-by-hash + database + (assq-ref opts 'storage) + metrics-registry + (store-path-hash-part store-path) + #:error-unless-files-to-remove? #f)) + (log-msg + 'WARN "no --storage set, so just removing from the database")) + + (for-each + (lambda (cached-narinfo-details) + ;; It might not have been scheduled for + ;; removal, but remove any schedule that + ;; exists + (database-delete-scheduled-cached-narinfo-removal + database + (assq-ref cached-narinfo-details 'id)) + + ;; Remove all the database entries first, as + ;; that'll stop these files appearing in narinfos + (database-remove-cached-narinfo-file + database + narinfo-id + (symbol->string compression))) + cached-narinfo-files) + + (database-remove-narinfo database store-path)) + (log-msg 'WARN store-path " not found to remove")))) (assq-ref opts 'arguments)))) + (("check" rest ...) + (let* ((opts (parse-options (append %base-options + %check-options) + (append %base-option-defaults + %check-option-defaults) + rest)) + (lgr (make <logger>)) + (port-log (make <port-log> + #:port (current-output-port) + #:formatter + ;; In guile-lib v0.2.8 onwards, the formatter is + ;; called with more arguments + (lambda args ; lvl, time, str + (format #f "~a (~5a): ~a~%" + (strftime "%F %H:%M:%S" (localtime + (second args))) + (first args) + (third args))))) + (metrics-registry (make-metrics-registry + #:namespace + "narherder"))) + + (add-handler! lgr port-log) + (open-log! lgr) + (set-default-logger! lgr) + + (let ((log-level (assq-ref opts 'log-level))) + (let loop ((levels %valid-log-levels)) + (when (and (not (null? levels)) + (not (eq? (car levels) log-level))) + (disable-log-level! lgr (car levels)) + (loop (cdr levels))))) + + (let* ((database (setup-database (assq-ref opts 'database) + metrics-registry)) + (canonical-storage (and=> (assq-ref opts 'storage) + canonicalize-path))) + + (check-storage database + canonical-storage + metrics-registry)))) (("run-server" rest ...) (simple-format (current-error-port) "locale is ~A\n" (check-locale!)) @@ -317,37 +573,14 @@ (port-log (make <port-log> #:port (current-output-port) #:formatter - (lambda (lvl time str) + ;; In guile-lib v0.2.8 onwards, the formatter is + ;; called with more arguments + (lambda args ; lvl, time, str (format #f "~a (~5a): ~a~%" - (strftime "%F %H:%M:%S" (localtime time)) - lvl - str)))) - (metrics-registry (make-metrics-registry - #:namespace - "narherder"))) - - (define (download-database) - (let ((database-uri - (string->uri - (string-append (assq-ref opts 'mirror) - "/latest-database-dump")))) - (call-with-values - (lambda () - (simple-format (current-error-port) - "starting downloading the database\n") - (http-get database-uri - #:decode-body? #f - #:streaming? #t)) - (lambda (response body) - (when (not (= (response-code response) 200)) - (error "unable to fetch database from mirror")) - - (call-with-output-file (assq-ref opts 'database) - (lambda (output-port) - (dump-port body output-port))) - - (simple-format (current-error-port) - "finished downloading the database\n"))))) + (strftime "%F %H:%M:%S" (localtime + (second args))) + (first args) + (third args)))))) (add-handler! lgr port-log) (open-log! lgr) @@ -378,73 +611,4 @@ (lambda (port) (simple-format port "~A\n" (getpid)))))) - (and=> - (assq-ref opts 'mirror) - (lambda (mirror) - (let ((database-file (assq-ref opts 'database))) - (if (file-exists? database-file) - (begin - ;; TODO Open the database, and check if the - ;; latest changes in the database are visible on - ;; the source to mirror. If they're not, then - ;; delete the database and download it to get - ;; back in sync - - #f) - (download-database))))) - - (let ((database (setup-database (assq-ref opts 'database) - metrics-registry)) - (canonical-storage (and=> (assq-ref opts 'storage) - canonicalize-path))) - - (when (not (file-exists? (assq-ref opts 'database-dump))) - (log-msg 'INFO "dumping database...") - (dump-database database (assq-ref opts 'database-dump))) - - (start-recent-change-removal-and-database-dump-thread - database - (assq-ref opts 'database-dump) - (* 24 3600) ; 24 hours - (assq-ref opts 'recent-changes-limit)) - - (and=> (assq-ref opts 'mirror) - (lambda (mirror) - (start-fetch-changes-thread 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)))) - - - (when (and (assq-ref opts 'storage) - (number? (assq-ref opts 'storage-limit))) - (start-nar-removal-thread database - canonical-storage - (assq-ref opts 'storage-limit) - metrics-registry - (filter-map - (match-lambda - ((key . val) - (if (eq? key 'storage-nar-removal-criteria) - val - #f))) - opts))) - - (log-msg 'INFO "starting server, listening on " - (assq-ref opts 'host) ":" (assq-ref opts 'port)) - (run-server - (make-request-handler database - canonical-storage - #:ttl (assq-ref opts 'narinfo-ttl) - #:negative-ttl (assq-ref opts 'narinfo-negative-ttl) - #:logger lgr - #:metrics-registry metrics-registry) - #:host (assq-ref opts 'host) - #:port (assq-ref opts 'port)))))) + (run-nar-herder-service opts lgr)))) |