diff options
| -rw-r--r-- | nar-herder/server.scm | 12 | ||||
| -rw-r--r-- | scripts/nar-herder.in | 36 |
2 files changed, 37 insertions, 11 deletions
diff --git a/nar-herder/server.scm b/nar-herder/server.scm index 8455d72..97335c0 100644 --- a/nar-herder/server.scm +++ b/nar-herder/server.scm @@ -21,6 +21,7 @@ #:use-module (web uri) #:use-module (web response) #:use-module (web request) + #:use-module (logging logger) #:use-module (json) #:use-module (nar-herder database) #:use-module (nar-herder storage) @@ -45,17 +46,18 @@ (() '())))) (define* (make-request-handler database storage-root - #:key ttl negative-ttl) + #:key ttl negative-ttl logger) (define (narinfo? str) (and (= (string-length str) 40) (string-suffix? ".narinfo" str))) (lambda (request body) - (simple-format (current-error-port) - "~A ~A\n" - (request-method request) - (uri-path (request-uri request))) + (log-msg logger + 'DEBUG + (request-method request) + " " + (uri-path (request-uri request))) (match (cons (request-method request) (split-and-decode-uri-path diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in index 0f4f7f2..fd4b7b4 100644 --- a/scripts/nar-herder.in +++ b/scripts/nar-herder.in @@ -60,6 +60,9 @@ (nar-herder mirror) (nar-herder server)) +(define %valid-log-levels + '(DEBUG INFO WARN ERROR)) + (define %base-options (list (option '("database") #t #f (lambda (opt name arg result) @@ -161,12 +164,26 @@ (lambda (opt name arg result) (alist-cons 'mirror arg - (alist-delete 'mirror result)))))) + (alist-delete 'mirror 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 %server-option-defaults '((port . 8080) (host . "0.0.0.0") + (log-level . 'DEBUG) + (storage-limit . "none") (recent-changes-limit . 32768))) @@ -282,6 +299,13 @@ (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))))) + (unless (null? unknown-arguments) (simple-format (current-error-port) "unknown arguments: ~A\n" @@ -319,8 +343,7 @@ (simple-format port "~A\n" (getpid)))))) (when (not (file-exists? (assq-ref opts 'database-dump))) - (simple-format (current-error-port) - "dumping database...\n") + (log-msg 'INFO "dumping database...") (dump-database database (assq-ref opts 'database-dump))) (start-recent-change-removal-and-database-dump-thread @@ -353,12 +376,13 @@ #f))) opts))) - (simple-format (current-error-port) - "starting server\n") + (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)) + #:negative-ttl (assq-ref opts 'narinfo-negative-ttl) + #:logger lgr) #:host (assq-ref opts 'host) #:port (assq-ref opts 'port)))))) |