mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
8b5eb68238
They can be close()d explicitly with close-file-descriptor, and will close() on gc, but only explicitly closing the last port on them will close the fileno. Notably needed for network sockets where we open separate input and output ports on the same socket.
232 lines
8.8 KiB
Scheme
232 lines
8.8 KiB
Scheme
;; log.scm -- customizable logging with levels
|
|
;; Copyright (c) 2005-2013 Alex Shinn. All rights reserved.
|
|
;; BSD-style license: http://synthcode.com/license.txt
|
|
|
|
(define-record-type Logger
|
|
(make-logger levels level-abbrevs current-level prefix prefix-spec
|
|
counts file port locked? zipped?)
|
|
logger?
|
|
(levels logger-levels logger-levels-set!)
|
|
(level-abbrevs logger-level-abbrevs logger-level-abbrevs-set!)
|
|
(current-level logger-current-level %logger-current-level-set!)
|
|
(prefix logger-prefix %logger-prefix-set!)
|
|
(prefix-spec logger-prefix-spec logger-prefix-spec-set!)
|
|
(counts logger-counts logger-counts-set!)
|
|
(file logger-file logger-file-set!)
|
|
(port logger-port logger-port-set!)
|
|
(locked? logger-locked? logger-locked?-set!)
|
|
(zipped? logger-zipped? logger-zipped?-set!))
|
|
|
|
(define (logger-prefix-set! logger prefix)
|
|
(%logger-prefix-set! logger (log-compile-prefix prefix))
|
|
(logger-prefix-set! logger prefix))
|
|
|
|
(define (logger-current-level-set! logger level)
|
|
(%logger-current-level-set! logger (log-level-index logger level)))
|
|
|
|
(define-syntax define-logger
|
|
(syntax-rules ()
|
|
((define-logger logger (levels ...))
|
|
(def-logger logger (levels ...) log-default-prefix 0 () ()))))
|
|
|
|
(define-syntax def-logger
|
|
(syntax-rules ()
|
|
((def-logger logger ((#f name) . rest) prefix n (names ...) defs)
|
|
(def-logger logger rest prefix (+ n 1) (names ... name) defs))
|
|
((def-logger logger ((level name) . rest) prefix n (names ...) (defs ...))
|
|
(def-logger logger rest prefix (+ n 1)
|
|
(names ... name)
|
|
(defs ...
|
|
(define-syntax level
|
|
(syntax-rules ()
|
|
((level . args)
|
|
(if (<= n (logger-current-level logger))
|
|
(log-show logger n . args))))))))
|
|
((def-logger logger ((level name . x) . rest) . y)
|
|
(syntax-error "bad logger level: " (level name . x)))
|
|
((def-logger logger (level . rest) prefix n names defs)
|
|
(def-logger logger ((level (log-normalize-name 'level)) . rest)
|
|
prefix n names defs))
|
|
((def-logger logger () prefix n (names ...) (defs ...))
|
|
(begin
|
|
defs ...
|
|
(define logger
|
|
(let ((names-vec (vector names ...)))
|
|
(make-logger
|
|
names-vec
|
|
(log-generate-abbrevs names-vec)
|
|
n
|
|
(log-compile-prefix prefix)
|
|
prefix
|
|
'() #f (current-error-port) #f #f)))))))
|
|
|
|
(define (log-normalize-name name)
|
|
(let ((str (symbol->string name)))
|
|
(if (string-prefix? "log-" str)
|
|
(string->symbol (substring str 4))
|
|
name)))
|
|
|
|
(define (log-level-index logger level)
|
|
(if (integer? level)
|
|
level
|
|
(let ((len (vector-length (logger-levels logger))))
|
|
(let lp ((i 0))
|
|
(cond
|
|
((= i len)
|
|
(error "unknown log level" (logger-levels logger) level))
|
|
((eq? level (vector-ref (logger-levels logger) i)) i)
|
|
(else (lp (+ i 1))))))))
|
|
|
|
(define (log-level-name logger level)
|
|
(cond
|
|
((symbol? level)
|
|
level)
|
|
((< level (vector-length (logger-levels logger)))
|
|
(vector-ref (logger-levels logger) level))
|
|
(else
|
|
(let ((len (vector-length (logger-levels logger))))
|
|
(string->symbol
|
|
(string-append
|
|
(symbol->string (vector-ref (logger-levels logger) (- len 1)))
|
|
"-" (number->string (- level len))))))))
|
|
|
|
(define (log-level-abbrev logger level)
|
|
(cond
|
|
((symbol? level)
|
|
(log-level-abbrev logger (log-level-index logger level)))
|
|
((< level (vector-length (logger-level-abbrevs logger)))
|
|
(vector-ref (logger-level-abbrevs logger) level))
|
|
(else
|
|
(number->string level))))
|
|
|
|
(define (log-generate-abbrevs abbrevs)
|
|
(let* ((len (vector-length abbrevs))
|
|
(res (make-vector len)))
|
|
(do ((i 0 (+ i 1)))
|
|
((= i len) res)
|
|
(let ((name (symbol->string (vector-ref abbrevs i))))
|
|
(vector-set! res i (string (char-upcase (string-ref name 0))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; procedural interface
|
|
|
|
(define (log-generate-output logger level args)
|
|
(let ((prefix ((logger-prefix logger) logger level))
|
|
(message (show #f (each-in-list args))))
|
|
(string-append
|
|
prefix
|
|
(string-concatenate (string-split message #\newline)
|
|
(string-append "\n" prefix))
|
|
"\n")))
|
|
|
|
(define (log-compile-prefix spec)
|
|
(define (pad2 n)
|
|
(if (< n 10)
|
|
(string-append "0" (number->string n))
|
|
(number->string n)))
|
|
(define (log-compile-one-prefix x)
|
|
(if (string? x)
|
|
(lambda (lg time level) x)
|
|
(case x
|
|
((year)
|
|
(lambda (lg time level) (number->string (+ 1900 (time-year time)))))
|
|
((month) (lambda (lg time level) (pad2 (+ 1 (time-month time)))))
|
|
((day) (lambda (lg time level) (pad2 (time-day time))))
|
|
((hour) (lambda (lg time level) (pad2 (time-hour time))))
|
|
((minute) (lambda (lg time level) (pad2 (time-minute time))))
|
|
((second) (lambda (lg time level) (pad2 (time-second time))))
|
|
((level)
|
|
(lambda (lg time level) (symbol->string (log-level-name lg level))))
|
|
((level-abbrev)
|
|
(lambda (lg time level) (log-level-abbrev lg level)))
|
|
((pid) (lambda (lg time level) (number->string (current-process-id))))
|
|
((uid) (lambda (lg time level) (number->string (current-group-id))))
|
|
((gid) (lambda (lg time level) (number->string (current-user-id))))
|
|
(else (error "unknown logging spec" x)))))
|
|
(let ((procs (map log-compile-one-prefix spec)))
|
|
(lambda (logger level)
|
|
(let ((time (seconds->time (current-seconds))))
|
|
(let lp ((ls procs) (res '()))
|
|
(if (null? ls)
|
|
(string-concatenate (reverse res))
|
|
(lp (cdr ls) (cons ((car ls) logger time level) res))))))))
|
|
|
|
(define log-default-prefix
|
|
'(year "-" month "-" day " " hour ":" minute ":" second " " level-abbrev " "))
|
|
|
|
(define (log-open logger . o)
|
|
(if (pair? o)
|
|
(logger-file-set! logger (car o)))
|
|
(if (string? (logger-file logger))
|
|
(let ((fd (open (logger-file logger)
|
|
(+ open/create open/write open/append open/non-block))))
|
|
(logger-port-set! logger (open-output-file-descriptor fd)))
|
|
(logger-port-set! logger (current-error-port))))
|
|
|
|
(define (log-close logger)
|
|
(if (output-port? (logger-port logger))
|
|
(close-output-port (logger-port logger))))
|
|
|
|
;; Use file-locking to let multiple processes write to the same log
|
|
;; file. On error try to re-open the log file. We keep the port open
|
|
;; so that even if you mv the file (e.g. when rotating logs) we keep
|
|
;; writing to it in the new location. To force writing to a new file
|
|
;; in the original location, use cp+rm instead of mv, so that the
|
|
;; logging will error and try to re-open.
|
|
(define (log-show logger level . args)
|
|
(cond
|
|
((<= level (logger-current-level logger))
|
|
(let ((str (log-generate-output logger level args)))
|
|
(let lp ((first? #t))
|
|
(let ((out (logger-port logger)))
|
|
(protect (exn
|
|
(else
|
|
(cond
|
|
(first? ; try to re-open log-file once
|
|
(log-close logger)
|
|
(log-open logger)
|
|
(lp #f))
|
|
(else ; fall back to stderr
|
|
(display str (current-error-port))))))
|
|
(let ((locked? (and (logger-locked? logger)
|
|
(output-port? out)
|
|
(file-lock out lock/exclusive))))
|
|
;; this is redundant with POSIX O_APPEND
|
|
;; (set-file-position! out 0 seek/end)
|
|
(display str out)
|
|
(flush-output out)
|
|
(if locked? (file-lock out lock/unlock))))))))))
|
|
|
|
(define (log-show-every-n logger level id n . args)
|
|
(cond
|
|
((assq id (logger-counts logger))
|
|
=> (lambda (cell)
|
|
(if (zero? (modulo (cdr cell) n))
|
|
(apply log-show logger level args))))
|
|
(else
|
|
(logger-counts-set! logger (cons (cons id 0) (logger-counts logger)))
|
|
(apply log-show logger level args))))
|
|
|
|
;; http://httpd.apache.org/docs/2.2/mod/core.html#loglevel
|
|
|
|
(define-logger default-logger
|
|
(log-emergency ; the server is on fire!!!
|
|
log-alert ; couldn't write to user mailbox
|
|
log-critical ; couldn't run 'dig' executable
|
|
log-error ; error loading user filter
|
|
log-warn ; invalid smtp command; relay failed
|
|
log-notice ; saved to file/relayed to address
|
|
log-info ; loaded alias file
|
|
log-debug)) ; spam-probability: 0.5
|
|
|
|
(define-syntax with-logged-errors
|
|
(syntax-rules ()
|
|
((with-logged-errors . body)
|
|
(protect (exn (else (log-error exn)))
|
|
. body))))
|
|
|
|
(define-syntax with-logged-and-reraised-errors
|
|
(syntax-rules ()
|
|
((with-logged-errors . body)
|
|
(protect (exn (else (log-error exn) (raise exn)))
|
|
. body))))
|