126 lines
3.5 KiB
Racket
126 lines
3.5 KiB
Racket
#lang racket
|
|
|
|
(require (for-syntax racket/syntax)
|
|
racket/date
|
|
racket-sprintf
|
|
)
|
|
|
|
(provide def-log
|
|
log-to
|
|
log-to-file
|
|
log-to-display
|
|
)
|
|
|
|
(define (iso-timestamp)
|
|
(let* ([d (seconds->date (current-seconds))])
|
|
(sprintf "%04d-%02d-%02dT%02d:%02d:%02d"
|
|
(date-year d)
|
|
(date-month d)
|
|
(date-day d)
|
|
(date-hour d)
|
|
(date-minute d)
|
|
(date-second d))))
|
|
|
|
(define (log-to* receiver log-callbacks)
|
|
(void
|
|
(thread
|
|
(λ () (let loop ()
|
|
(let* ((v (sync receiver))
|
|
(level (vector-ref v 0))
|
|
(msg (vector-ref v 1))
|
|
(data (vector-ref v 2))
|
|
(dt (car data))
|
|
(topic (cadr data))
|
|
)
|
|
(for-each (λ (e)
|
|
(let ((callback (cdr e)))
|
|
(callback topic level dt msg)))
|
|
(log-callbacks))
|
|
)
|
|
(loop)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-syntax (log-to stx)
|
|
(syntax-case stx ()
|
|
((_ id name callback)
|
|
(with-syntax ([log-callbacks (format-id #'id "log-callbacks-~a" #'id)])
|
|
#'(set! log-callbacks (append
|
|
(filter (λ (e)
|
|
(not (eq? (car e) 'name)))
|
|
log-callbacks) (list (cons 'name callback))))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-syntax log-to-display
|
|
(syntax-rules (display)
|
|
((_ id)
|
|
(log-to id display
|
|
(λ (topic level dt msg)
|
|
(displayln (format "~a:~a:~a:~a" topic level dt msg)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-syntax log-to-file
|
|
(syntax-rules (file)
|
|
((_ id filename)
|
|
(let ((out (open-output-file filename #:exists 'replace)))
|
|
(log-to id file (λ (topic level dt msg)
|
|
(displayln (format "~a:~a:~a:~a" topic level dt msg) out)
|
|
(flush-output out))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
(define-syntax def-log2
|
|
(syntax-rules ()
|
|
((_ id parent receiver log-callbacks dbgn infon warnn errn fataln)
|
|
(begin
|
|
(define l (make-logger 'id parent))
|
|
(define log-callbacks '())
|
|
(define receiver (make-log-receiver l 'debug))
|
|
(define (log level msg args)
|
|
(log-message l level #f (apply format (cons msg args)) (list (iso-timestamp) 'id)))
|
|
(define (dbgn msg . args) (log 'debug msg args))
|
|
(define (infon msg . args) (log 'info msg args))
|
|
(define (warnn msg . args) (log 'warning msg args))
|
|
(define (errn msg . args) (log 'error msg args))
|
|
(define (fataln msg . args) (log 'fatal msg args))
|
|
(log-to* receiver (λ () log-callbacks))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
(define-syntax (def-log stx)
|
|
(syntax-case stx ()
|
|
((_ id parent)
|
|
(with-syntax ([receiver (format-id #'id "receiver-~a" #'id)]
|
|
[callbacks (format-id #'id "log-callbacks-~a" #'id)]
|
|
[dbg-name (format-id #'id "dbg-~a" #'id)]
|
|
[info-name (format-id #'id "info-~a" #'id)]
|
|
[warn-name (format-id #'id "warn-~a" #'id)]
|
|
[err-name (format-id #'id "err-~a" #'id)]
|
|
[fatal-name (format-id #'id "fatal-~a" #'id)]
|
|
)
|
|
#'(def-log2 id parent receiver callbacks dbg-name info-name warn-name err-name fatal-name)
|
|
)
|
|
)
|
|
((_ id)
|
|
#'(def-log id (current-logger))
|
|
)
|
|
)
|
|
)
|
|
|