125 lines
4.1 KiB
Racket
125 lines
4.1 KiB
Racket
#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/format racket/match racket/string)
|
|
|
|
(provide global-logger install-logging!)
|
|
|
|
(define global-logger (make-logger))
|
|
|
|
(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)
|
|
(flush-output (current-output-port))))
|
|
|
|
;; process log entries until told to stop
|
|
;; this uses the same technique as with-intercepted-logging
|
|
(let loop ()
|
|
(match (sync receiver stop-chan)
|
|
['stop (void)]
|
|
[next
|
|
(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 recv
|
|
(make-log-receiver
|
|
global-logger
|
|
;; set of default filters
|
|
;; https://groups.google.com/g/racket-users/c/Nl4DNKUI2tk/m/Qzt58ib9BAAJ
|
|
'info 'optimizer
|
|
'warning 'collapsible-contract-bailout
|
|
'warning 'collapsible-value-bailout
|
|
'warning 'racket/contract
|
|
'warning 'cm-accomplice
|
|
'info 'GC
|
|
'warning 'module-prefetch
|
|
'info 'sequence-specialization
|
|
;; default level
|
|
level #f))
|
|
(define stop-chan (make-channel))
|
|
(define logger-thd (thread (lambda () (recv-thd recv stop-chan))))
|
|
|
|
(current-logger global-logger)
|
|
|
|
;; install (approximate) stack trace printer
|
|
(error-display-handler
|
|
(lambda (msg ex)
|
|
(define exn-type
|
|
(if (exn? ex)
|
|
(let*-values ([(ty _) (struct-info ex)]
|
|
[(name _2 _3 _4 _5 _6 _7 _8) (struct-type-info ty)])
|
|
(symbol->string name))
|
|
(~a ex)))
|
|
(define msg-str (~a msg))
|
|
(define stack-trace
|
|
(if (exn? ex)
|
|
(for/list ([ctx (in-list (continuation-mark-set->context (exn-continuation-marks ex)))])
|
|
(match (cdr ctx)
|
|
[#f (format " at ~a (<unknown source>)\n" (car ctx))]
|
|
[(srcloc source line column position span)
|
|
(format " at ~a (~a:~a:~a)\n" (or (car ctx) "<unknown>") source line column)]))
|
|
'("<unknown stack trace>")))
|
|
(log-message global-logger 'fatal
|
|
(apply string-append exn-type ": " msg-str "\n" stack-trace))))
|
|
|
|
;; 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)))
|