From d80c7ff152e1e907d64fdd3555e2b43c2a83e1fc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 8 Oct 2013 21:40:06 +0900 Subject: [PATCH] Adding customizable logging library with combinator formatting. --- lib/chibi/log.scm | 232 ++++++++++++++++++++++++++++++++++++++++++++++ lib/chibi/log.sld | 26 ++++++ 2 files changed, 258 insertions(+) create mode 100644 lib/chibi/log.scm create mode 100644 lib/chibi/log.sld diff --git a/lib/chibi/log.scm b/lib/chibi/log.scm new file mode 100644 index 00000000..4768d7c1 --- /dev/null +++ b/lib/chibi/log.scm @@ -0,0 +1,232 @@ +;; 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)))) diff --git a/lib/chibi/log.sld b/lib/chibi/log.sld new file mode 100644 index 00000000..1aa480ca --- /dev/null +++ b/lib/chibi/log.sld @@ -0,0 +1,26 @@ + +(define-library (chibi log) + (export + ;; Logger record + Logger logger? + logger-levels logger-levels-set! + logger-level-abbrevs logger-level-abbrevs-set! + logger-current-level logger-current-level-set! + logger-prefix logger-prefix-set! + logger-counts logger-counts-set! + logger-file logger-file-set! + logger-port logger-port-set! + logger-locked? logger-locked?-set! + logger-zipped? logger-zipped?-set! + ;; syntax + define-logger with-logged-errors with-logged-and-reraised-errors + ;; procedural interface + log-open log-close log-show log-show-every-n log-compile-prefix + ;; levels introspection + log-level-index log-level-name log-level-abbrev + ;; the default logger + default-logger log-emergency log-alert log-critical log-error + log-warn log-notice log-info log-debug) + (import (chibi) (srfi 9) (chibi time) (chibi process) (chibi system) + (chibi filesystem) (chibi string) (chibi show)) + (include "log.scm"))