1#lang racket/base
2(require "../common/check.rkt"
3         "../host/thread.rkt"
4         "../host/place-local.rkt"
5         "logger.rkt"
6         "level.rkt"
7         "wanted.rkt"
8         "receiver.rkt")
9
10(provide logger?
11         logger-name
12         current-logger
13         unsafe-root-logger
14         make-logger
15         log-level?
16         log-level?*   ; ok to call in host-Scheme interrupt handler
17         log-max-level
18         log-all-levels
19         log-level-evt
20         log-message
21         log-message*  ; ok to call in host-Scheme interrupt handler
22         log-receiver?
23         make-log-receiver
24         add-stderr-log-receiver!
25         add-stdout-log-receiver!
26         add-syslog-log-receiver!
27         logger-init!
28         logging-future-events?
29         log-future-event
30         logging-place-events?
31         log-place-event)
32
33(define (make-root-logger)
34  (create-logger #:topic #f #:parent #f #:propagate-filters 'none))
35
36(define-place-local root-logger (make-root-logger))
37
38(define (unsafe-root-logger) root-logger)
39
40(define current-logger
41  (make-parameter root-logger
42                  (lambda (l)
43                    (unless (logger? l)
44                      (raise-argument-error 'current-logger "logger?" l))
45                    l)
46                  'current-logger))
47
48(define (logger-init!)
49  (set! root-logger (make-root-logger))
50  (current-logger root-logger))
51
52(define (make-logger [topic #f] [parent #f] . filters)
53  (unless (or (not topic) (symbol? topic))
54    (raise-argument-error 'make-logger "(or/c symbol? #f)" topic))
55  (unless (or (not parent) (logger? parent))
56    (raise-argument-error 'make-logger "(or/c logger? #f)" parent))
57  (create-logger #:topic topic
58                 #:parent parent
59                 #:propagate-filters (parse-filters 'make-logger filters #:default-level 'debug)))
60
61;; Can be called in any host Scheme thread, including in an interrupt
62;; handler (where "interrupt" is a host-Scheme concept, such as a GC
63;; handler). If it's not the thread that runs Racket, then it's in
64;; atomic, non-interrupt mode and we assume that the argument checks
65;; will pass.
66(define/who (log-level? logger level [topic #f])
67  (check who logger? logger)
68  (check-level who level)
69  (check who #:or-false symbol? topic)
70  (atomically/no-interrupts/no-wind
71   (log-level?* logger level topic)))
72
73(define (logging-future-events?)
74  (atomically/no-interrupts/no-wind
75   (log-level?* root-logger 'debug 'future)))
76
77(define (logging-place-events?)
78  (atomically/no-interrupts/no-wind
79   (log-level?* root-logger 'debug 'place)))
80
81;; In atomic mode with interrupts disabled
82(define/who (log-level?* logger level topic)
83  (level>=? (logger-wanted-level logger topic) level))
84
85(define/who (log-max-level logger [topic #f])
86  (check who logger? logger)
87  (check who #:or-false symbol? topic)
88  (level->user-representation
89   (atomically/no-interrupts/no-wind
90    (logger-wanted-level logger topic))))
91
92(define/who (log-all-levels logger)
93  (check who logger? logger)
94  (logger-all-levels logger))
95
96(define/who (log-level-evt logger)
97  (check who logger? logger)
98  (define s
99    (atomically
100     (cond
101       [(unbox (logger-level-sema-box logger))
102        => (lambda (s) s)]
103       [else
104        (define s (make-semaphore))
105        (set-box! (logger-level-sema-box logger) s)
106        s])))
107  (semaphore-peek-evt s))
108
109(define/who log-message
110  ;; Complex dispatch based on number and whether third is a string:
111  (case-lambda
112    [(logger level message)
113     (define topic (and (logger? logger) (logger-name logger)))
114     (do-log-message who logger level topic message #f #t)]
115    [(logger level topic/message message/data)
116     (cond
117       [(string? topic/message)
118        (define topic (and (logger? logger) (logger-name logger)))
119        (do-log-message who logger level topic topic/message message/data #t)]
120       [(or (not topic/message) (symbol? topic/message))
121        (do-log-message who logger level topic/message message/data #f #t)]
122       [else
123        (check who logger? logger)
124        (check-level who level)
125        (raise-argument-error who "(or/c string? symbol?)" topic/message)])]
126    [(logger level topic/message message/data data/prefix?)
127     (cond
128       [(string? topic/message)
129        (define topic (and (logger? logger) (logger-name logger)))
130        (do-log-message who logger level topic topic/message message/data data/prefix?)]
131       [(or (not topic/message) (symbol? topic/message))
132        (do-log-message who logger level topic/message message/data data/prefix? #t)]
133       [else
134        (check who logger? logger)
135        (check-level who level)
136        (raise-argument-error who "(or/c string? symbol?)" topic/message)])]
137    [(logger level topic message data prefix?)
138     (do-log-message who logger level topic message data prefix?)]))
139
140(define (do-log-message who logger level topic message data prefix?)
141  (check who logger? logger)
142  (check-level who level)
143  (check who #:or-false symbol? topic)
144  (check who string? message)
145  (atomically/no-interrupts/no-wind
146   (log-message* logger level topic message data prefix? #f)))
147
148(define (log-future-event message data)
149  (atomically/no-interrupts/no-wind
150   (log-message* root-logger 'debug 'future message data #t #f)))
151
152(define (log-place-event message data)
153  (atomically/no-interrupts/no-wind
154   (log-message* root-logger 'debug 'place message data #t #f)))
155
156;; In atomic mode with interrupts disabled
157;; Can be called in any host Scheme thread and in interrupt handler,
158;; like `log-level?*`
159(define (log-message* logger level topic message data prefix? in-interrupt?)
160  (define msg #f)
161  (when ((logger-max-wanted-level* logger) . level>=? . level)
162    (let loop ([logger logger])
163      (for ([r (in-list (logger-receivers logger))])
164        (when ((filters-level-for-topic (log-receiver-filters r) topic) . level>=? . level)
165          (unless msg
166            (set! msg (vector-immutable
167                       level
168                       (string->immutable-string
169                        (if (and prefix? topic)
170                            (string-append (symbol->string topic)
171                                           ": "
172                                           message)
173                            message))
174                       data
175                       topic)))
176          (log-receiver-send! r msg in-interrupt?)))
177      (let ([parent (logger-parent logger)])
178        (when (and parent
179                   ((filters-level-for-topic (logger-propagate-filters logger) topic) . level>=? . level))
180          (loop parent))))))
181