simple-log/main.rkt

#lang racket

(require (for-syntax racket/syntax)
         racket/date
         racket-sprintf
         racket/async-channel
         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
         sl-sync
         )

(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 sync-count 0)
(define sync-sems (make-hash))

(define (sl-sync l topic)
  (let ((sem (hash-ref sync-sems topic #f)))
    (when (eq? sem #f)
      (set! sem (make-semaphore))
      (hash-set! sync-sems topic sem))
    (log-message l 'fatal #f "@@SYNC@@" (list (iso-timestamp) topic))
    (semaphore-wait sem)))

(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-async-channel))
(define buffer-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-hash (hash 'debug 0 'dbg 0
                       'info 1
                       'warning 2 'warn 2
                       'err 3 'error 3
                       'fatal 5))

(define (needs-logging level)
  (let ((ll (hash-ref log-hash log-level 6))
        (l (hash-ref log-hash level 6)))
    (>= l ll)))

(define logger-thread #f)

(when (eq? logger-thread #f)
  (set! logger-thread 
        (thread
         (λ () (let loop ((v (sync log-queue)))

                 (let* ((level (vector-ref v 0))
                        (msg (vector-ref v 1))
                        (data (vector-ref v 2))
                        (dt (car data))
                        (topic (cadr data))
                        (lc log-callbacks))

                   (when (string=? msg "@@SYNC@@")
                     (let ((sem (hash-ref sync-sems topic #f)))
                       (if (eq? sem #f)
                           (begin
                             (set! msg (format "Cannot synchronize on topic ~a" topic))
                             (set! level 'error))
                           (begin
                             (semaphore-post sem)
                             (set! msg (format "Synchronization received on topic ~a" topic))
                             (set! level 'debug)
                             )
                           )))

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

                 (loop (let ((a (async-channel-try-get log-queue)))
                         (if (eq? a #f)
                             (sync log-queue)
                             a)))
                 )
           )
         #:pool 'own
         )
        )
  )

(define (log-to* receiver log-callbacks)
  (void
   (thread
    (λ () (let loop ()
            (let* ((v (sync receiver)))
              (async-channel-put log-queue v))
            (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 syncn)
     (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))
       (define (syncn) (sl-sync l 'id))
       (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)]
                   [sync-name (format-id #'id "sync-log-~a" #'prefix)]
                   )
       #'(def-log2 id parent receiver log-callbacks dbg-name info-name warn-name err-name fatal-name sync-name)
       )
     )
    ((_ id name)
     #'(sl-def-log id name #f)
     )
    ((_ id)
     #'(sl-def-log id id #f)
     )
    )
  )

(sl-def-log simple-log)