add fancy logging handler

crossfire/logging.rkt

@@ -0,0 +1,101 @@
+#lang racket/base
+;; crossfire: distributed brute force infrastructure
+;;
+;; Copyright (C) 2020 haskal
+;;
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+(require racket/bool racket/date racket/match racket/string)
+
+(provide install-logging!)
+
+(define (recv-thd receiver stop-chan)
+  ;; iso8601 gang
+  (date-display-format 'iso-8601)
+
+  ;; formats one log entry to stdout
+  (define (log-one entry)
+    (match-define (vector level msg arg topic) entry)
+    (define level-str
+      (match level
+        ['fatal   "FATAL"]
+        ['error   "ERROR"]
+        ['warning "WARN "]
+        ['info    "INFO "]
+        ['debug   "DEBUG"]
+        [_        "NONE "]))
+    ;; for systemd
+    (define prefix-str
+      (match level
+        ['fatal   "<2>"]
+        ['error   "<3>"]
+        ['warning "<4>"]
+        ['info    "<6>"]
+        ['debug   "<7>"]
+        [_        "<7>"]))
+
+    ;; in UTC
+    (define time-str (date->string (seconds->date (* 0.001 (current-inexact-milliseconds)) #f) #t))
+    ;; prefix each line of the log entry with the metadata
+    (define msg-lines (string-split msg "\n"))
+    (for ([line (in-list msg-lines)])
+      (printf "~a [~aZ] [~a] ~a\n" prefix-str time-str level-str line)))
+
+  ;; process log entries until told to stop
+  ;; this uses the same technique as with-intercepted-logging
+  (let loop ()
+    (define next (sync receiver stop-chan))
+    (unless (symbol=? next 'stop)
+      (log-one next)
+      (loop)))
+
+  ;; flush any remaining log entries
+  (let cleanup ()
+    (define next (sync/timeout 0 receiver))
+    (when next
+      (log-one next)
+      (cleanup))))
+
+;; install the logging system
+;; call as early as possible in the application
+(define (install-logging! [level 'debug])
+  (define logger (make-logger))
+  (define recv (make-log-receiver logger level))
+  (define stop-chan (make-channel))
+  (define logger-thd (thread (lambda () (recv-thd recv stop-chan))))
+
+  (current-logger logger)
+
+  ;; make uncaught exceptions go through the log
+  ;; this uses the same (tbh, disgusting) trick as xrepl
+  ;; ideally backtraces wouldn't be magic implemented in C using private continuation marks that
+  ;; aren't accessible to the program (in BC) but whatever
+  ;; perhaps it's better in CS
+  (define original-handler (error-display-handler))
+  (error-display-handler
+    (lambda (msg ex)
+      (define os (open-output-string))
+      (parameterize ([current-error-port os])
+        (original-handler msg ex))
+      (log-message logger 'fatal
+                   (format "uncaught exception: ~a" (get-output-string os))
+                   (current-continuation-marks))))
+
+  ;; install plumber flush to stop and flush the log printer thread
+  (define (flush _)
+    (channel-put stop-chan 'stop)
+    (thread-wait logger-thd))
+
+  (void
+    (plumber-add-flush! (current-plumber) flush)))