add fancy logging handler
This commit is contained in:
parent
521e986937
commit
150bc8eccf
|
@ -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)))
|
Loading…
Reference in New Issue