diff --git a/crossfire/logging.rkt b/crossfire/logging.rkt new file mode 100644 index 0000000..7003e3d --- /dev/null +++ b/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 . + +(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)))