Adding customizable logging library with combinator formatting.

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))))

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"))