hans/simple-log
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Keep the log queue on a maximum depth.

Browse Source
This commit is contained in:
Hans Dijkema
2026-06-29 00:39:48 +02:00
parent 712fda3af8
commit 5d6dbee06f
1 changed files with 54 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files
main.rkt
+54 -44
View File
@@ -83,53 +83,63 @@
(l (hash-ref log-hash level 6)))
(>= l ll)))
(define logger-thread
(thread
(λ () (let loop ()
(let* ((v (sync log-queue))
(level (vector-ref v 0))
(msg (vector-ref v 1))
(data (vector-ref v 2))
(dt (car data))
(topic (cadr data))
(lc log-callbacks)
)
(define logger-thread #f)
(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 'info)
(when (eq? logger-thread #f)
(set! logger-thread
(thread
(λ () (let loop ()
(let* ((v (sync log-queue))
(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 'info)
)
)))
(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))
)
)
)))
(if (null? lc)
(enqueue! buffer-queue (list topic level dt msg))
(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))))
)
(loop))))
)
)
)
(define (log-to* receiver log-callbacks)