simple-log/main.rkt

#lang racket

(require (for-syntax racket/syntax)
         racket/date
         racket-sprintf
         data/queue
         )

(provide sl-def-log
         sl-log-to
         sl-log-to-file
         sl-log-to-display
         sl-log-to-file&display
         sl-set-log-level
         sl-log-level
         )

(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-callbacks #f)
(set! log-callbacks '())

(define log-level #f)
(set! log-level 'debug)

(define max-log-queue-len 1000)
(define log-queue (make-queue))

(define (sl-set-log-level l)
  (if (or
       (eq? l 'debug)
       (eq? l 'info)
       (eq? l 'warning)
       (eq? l 'warn)
       (eq? l 'err)
       (eq? l 'error)
       (eq? l 'dbg)
       (eq? l 'fatal))
      (set! log-level
            (cond
              ((eq? l 'err) 'error)
              ((eq? l 'warn) 'warning)
              ((eq? l 'dbg) 'debug)
              (else l)))
      (error "Log level must be 'debug ('dbg), 'info, 'warning ('warn), 'error ('err) or 'fatal")
      )
  log-level
  )

(define (sl-log-level)
  log-level)

(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))
                   (lc (log-callbacks))
                   )

              (enqueue! log-queue (list topic level dt msg))
              (unless (null? lc)
                (for-each (λ (log-entry)
                            (for-each (λ (e)
                                        (let ((callback (cdr e)))
                                          (apply callback log-entry)))
                                      lc)
                            )
                          (queue->list log-queue))
                (set! log-queue (make-queue)))
              (when (> (queue-length log-queue) max-log-queue-len)
                (dequeue! log-queue))
              )
            (loop)
            )
      )
    )
   )
  )

(define-syntax sl-log-to
  (syntax-rules (log-callbacks)
    ((_ name callback)
     (set! log-callbacks (append
                          (filter (λ (e) (not (eq? (car e) 'name)))
                                  log-callbacks)
                          (list (cons 'name callback)))
           )
     )
    )
  )

(define (sl-log-to-file&display filename)
  (log-to-display*)
  (log-to-file* filename)
  (dbg-simple-log "log to file and display enabled with file ~a" filename)
  )

(define (log-to-display*)
  (sl-log-to display
            (λ (topic level dt msg)
               (displayln (format "~a:~a:~a:~a" topic level dt msg)))
             )
  )
  

(define (sl-log-to-display)
  (log-to-display*)
  (dbg-simple-log "log-to-display enabled")
  )

(define (log-to-file* filename)
     (let ((out (open-output-file filename #:exists 'replace)))
       (sl-log-to file (λ (topic level dt msg)
                       (displayln (format "~a:~a:~a:~a" topic level dt msg) out)
                       (flush-output out))
               )
       )
  )

(define (sl-log-to-file filename)
  (log-to-file* filename)
  (dbg-simple-log "log-to-file enabled with file ~a" filename)
  )

(define-syntax def-log2
  (syntax-rules ()
    ((_ id parent receiver log-callbacks dbgn infon warnn errn fataln)
     (begin
       (define l (make-logger 'id parent))
       (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 (sl-def-log stx)
  (syntax-case stx (log-callbacks)
    ((_ id prefix parent)
     (with-syntax ([receiver (format-id #'id "receiver-~a" #'prefix)]
                   [dbg-name (format-id #'id "dbg-~a" #'prefix)]
                   [info-name (format-id #'id "info-~a" #'prefix)]
                   [warn-name (format-id #'id "warn-~a" #'prefix)]
                   [err-name (format-id #'id "err-~a" #'prefix)]
                   [fatal-name (format-id #'id "fatal-~a" #'prefix)]
                   )
       #'(def-log2 id parent receiver log-callbacks dbg-name info-name warn-name err-name fatal-name)
       )
     )
    ((_ id name)
     #'(sl-def-log id name #f)
     )
    ((_ id)
     #'(sl-def-log id id #f)
     )
    )
  )

(sl-def-log simple-log)