Support passing a log-level to the nar-herder server

This means that you can disable the output of requests by specifying a
log-level of INFO or greater.

Since the nar-herder may respond to so many requests, logging each one
is a bit excessive.

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))))))