simple-log/private/store.rkt

#lang racket

(require data/queue
         racket/contract
         "loghash.rkt"
         )

(provide make-sl-store
         sl-store-grep-message
         sl-store-grep-topic
         sl-store-grep-level
         sl-store-grep
         sl-store-tail
         sl-store-head
         sl-store-enqueue!
         sl-store->list
         sl-store->display
         sl-store-length
         sl-store-max-length
         )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data structures
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-struct sl-store
  (max-length [length #:mutable] queue)
  )

(define-struct sl-store-item
  (topic level date-time message))

(define make-sl-store* make-sl-store)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(set! make-sl-store (λ ([max-length 1000])
                      (make-sl-store* max-length 0 (make-queue))))

(define levels '(debug info warning warn err error dbg fatal))

(define (level? l)
  (memq l levels))

(define (invert-predicate pred invert?)
  (if invert?
      (lambda (item) (not (pred item)))
      pred))

(define (topic-filter? value)
  (or (symbol? value)
      (regexp? value)
      (and (list? value)
           (andmap (lambda (item)
                     (or (symbol? item) (regexp? item)))
                   value))))

(define (topic-matches? topic filter)
  (cond
    ((symbol? filter)
     (eq? filter topic))
    ((regexp? filter)
     (regexp-match? filter (symbol->string topic)))
    ((list? filter)
     (ormap (lambda (item) (topic-matches? topic item)) filter))
    (else #f)))

(define (copy-queue q pred)
  (let ((nq (make-queue)))
    (sequence-for-each
     (λ (item)
       (when (pred item)
         (enqueue! nq item)))
     (in-queue q))
    nq))

(define (level-regexp->level l-re [raise-error #t])
  (let ((str-levels (map symbol->string levels)))
    (letrec ((f (λ (l)
                  (if (null? l)
                      (if raise-error
                          (error (format "Regular expression '~a' does not match a level"))
                          'debug)
                      (if (regexp-match? l-re (car l))
                          (string->symbol (car l))
                          (f (cdr l)))
                      )
                  )
                ))
      (f str-levels))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define/contract (sl-store-enqueue! store topic level date-time msg)
  (-> sl-store? symbol? level? string? string? void?)
  (void
   (let ((queue (sl-store-queue store))
         (ml    (sl-store-max-length store)))
     (enqueue! queue (make-sl-store-item topic level date-time msg))
     (set-sl-store-length! store (+ (sl-store-length store) 1))
     (let loop ()
       (if (> (queue-length queue) ml)
           (begin
             (dequeue! queue)
             (set-sl-store-length! store (- (sl-store-length store) 1))
             (loop))
           #t))
     )
   )
  )

(define/contract (sl-store->list store)
  (-> sl-store? list?)
  (map (λ (item)
         (list (sl-store-item-topic item)
               (sl-store-item-level item)
               (sl-store-item-date-time item)
               (sl-store-item-message item)))
       (queue->list (sl-store-queue store))))

(define/contract (sl-store->display store)
  (-> sl-store? void?)
  (void
   (for-each (λ (e)
               (displayln
                (format "~a:~a:~a:~a" (car e) (cadr e) (caddr e) (cadddr e))))
             (sl-store->list store))))

(define/contract (sl-store-grep-level store level)
  (-> sl-store? (or/c regexp? level?) sl-store?)
  (let* ((lvl (if (level? level) level (level-regexp->level level)))
         (num-level (hash-ref log-hash lvl 0)))
    (let ((nq (copy-queue (sl-store-queue store)
                          (λ (item)
                            (let ((num-level-item (hash-ref log-hash
                                                            (sl-store-item-level item)
                                                            0)))
                              (>= num-level-item num-level))))))
      (make-sl-store* (sl-store-max-length store)
                      (queue-length nq)
                      nq))))


(define/contract (sl-store-grep-topic store filter #:invert? [invert? #f])
  (->* (sl-store? topic-filter?) (#:invert? boolean?) sl-store?)
  (let ((nq (copy-queue
             (sl-store-queue store)
             (invert-predicate
              (lambda (item)
                (topic-matches? (sl-store-item-topic item) filter))
              invert?))))
    (make-sl-store* (sl-store-max-length store)
                    (queue-length nq)
                    nq)))
                                

(define/contract (sl-store-grep-message store regexp #:invert? [invert? #f])
  (-> sl-store? regexp? sl-store?)
  (let ((nq (copy-queue (sl-store-queue store)
                        (invert-predicate
                         (λ (item)
                           (let ((msg (sl-store-item-message item)))
                             (regexp-match? regexp msg)))
                         invert?))))
    (make-sl-store* (sl-store-max-length store)
                    (queue-length nq)
                    nq)))
  
(define/contract (sl-store-grep store value #:invert? [invert? #f])
  (->* (sl-store? (or/c symbol? regexp?)) (#:invert? boolean?) sl-store?)
  (let ((lvl (hash-ref log-hash
                       (if (regexp? value)
                           (level-regexp->level value #f)
                           (level-regexp->level (pregexp (symbol->string value)) #f))
                       0)))
    (define (matches? item)
      (let ((topic (sl-store-item-topic item))
            (level (hash-ref log-hash (sl-store-item-level item) 0))
            (msg (sl-store-item-message item)))
        (and (>= level lvl)
             (or (if (symbol? value)
                     (if (level? value)
                         (or (>= level lvl) (eq? value topic))
                         (eq? value topic))
                     (regexp-match? value (symbol->string topic)))
                 (if (symbol? value)
                     #f
                     (regexp-match? value msg))))))
    (let ((nq (copy-queue (sl-store-queue store)
                          (invert-predicate matches? invert?))))
      (make-sl-store* (sl-store-max-length store)
                      (queue-length nq)
                      nq))))


(define (int>0? a)
  (and (integer? a) (> a 0)))

(define/contract (sl-store-tail store n)
  (-> sl-store? int>0? sl-store?)
  (let* ((q (sl-store-queue store))
         (from (if (>= n (queue-length q))
                   0
                   (- (queue-length q) n)))
         (i 0))
    (let ((nq (copy-queue q
                          (λ (item)
                            (if (>= i from)
                                #t
                                (begin
                                  (set! i (+ i 1))
                                  #f))))))
      (make-sl-store* (sl-store-max-length store) (queue-length nq) nq))))

(define/contract (sl-store-head store n)
  (-> sl-store? int>0? sl-store?)
  (let* ((q (sl-store-queue store))
         (until (if (>= n (queue-length q))
                    (queue-length q)
                    n))
         (i 0))
    (let ((nq (copy-queue q
                          (λ (item)
                            (set! i (+ i 1))
                            (<= i n)))))
      (make-sl-store* (sl-store-max-length store) (queue-length nq) nq))))