1#lang racket/base
2(require "../common/check.rkt"
3         "../../common/queue.rkt"
4         "../host/thread.rkt"
5         "../host/pthread.rkt"
6         "../host/rktio.rkt"
7         "../string/convert.rkt"
8         "../path/system.rkt"
9         "../path/path.rkt"
10         "level.rkt"
11         "logger.rkt")
12
13(provide (struct-out log-receiver)
14         make-log-receiver
15         add-stderr-log-receiver!
16         add-stdout-log-receiver!
17         add-syslog-log-receiver!
18         log-receiver-send!
19         receiver-add-topics)
20
21(struct log-receiver (filters))
22
23(define-values (prop:receiver-send receiver-send? receiver-send-ref)
24  (make-struct-type-property 'receiver-send))
25
26;; ----------------------------------------
27
28(struct queue-log-receiver log-receiver (msgs     ; queue of messages ready for `sync` [if `waiters` is null]
29                                         waiters  ; queue of (box callback) to receive ready messages [if `msgs` is null]
30                                         backref) ; box to make a self reference to avoid GC of a waiting receiver
31  #:reflection-name 'log-receiver
32  #:property
33  prop:receiver-send
34  (lambda (lr msg)
35    ;; called in atomic mode
36    (define b (queue-remove! (queue-log-receiver-waiters lr)))
37    (cond
38      [b
39       (decrement-receiever-waiters! lr)
40       (define select! (unbox b))
41       (set-box! b msg)
42       (select!)]
43      [else
44       (queue-add! (queue-log-receiver-msgs lr) msg)]))
45  #:property
46  prop:evt
47  (poller (lambda (lr ctx)
48            (define msg (queue-remove! (queue-log-receiver-msgs lr)))
49            (cond
50              [msg
51               (values (list msg) #f)]
52              [else
53               (define b (box (poll-ctx-select-proc ctx)))
54               (define n (begin
55                           (increment-receiever-waiters! lr)
56                           (queue-add! (queue-log-receiver-waiters lr) b)))
57               (values #f (control-state-evt
58                           async-evt
59                           (lambda (e) (unbox b))
60                           (lambda ()
61                             (queue-remove-node! (queue-log-receiver-waiters lr) n)
62                             (decrement-receiever-waiters! lr))
63                           void
64                           (lambda ()
65                             (define msg (queue-remove! (queue-log-receiver-msgs lr)))
66                             (cond
67                               [msg
68                                (set-box! b msg)
69                                (values msg #t)]
70                               [else
71                                (increment-receiever-waiters! lr)
72                                (set! n (queue-add! (queue-log-receiver-waiters lr) b))
73                                (values #f #f)]))))]))))
74
75(define/who (make-log-receiver logger level . args)
76  (check who logger? logger)
77  (define backref (box #f))
78  (define lr (queue-log-receiver (parse-filters 'make-log-receiver (cons level args) #:default-level 'none)
79                                 (make-queue)
80                                 (make-queue)
81                                 backref))
82  (add-log-receiver! logger lr backref)
83  lr)
84
85
86;; In atomic mode
87(define (decrement-receiever-waiters! lr)
88  (when (queue-empty? (queue-log-receiver-waiters lr))
89    (set-box! (queue-log-receiver-backref lr) #f)))
90
91;; In atomic mode
92(define (increment-receiever-waiters! lr)
93  (when (queue-empty? (queue-log-receiver-waiters lr))
94    (set-box! (queue-log-receiver-backref lr) lr)))
95
96;; ----------------------------------------
97
98(struct stdio-log-receiver log-receiver (rktio which)
99  #:property
100  prop:receiver-send
101  (lambda (lr msg)
102    ;; called in atomic mode and possibly in host interrupt handler
103    (define rktio (stdio-log-receiver-rktio lr))
104    (define fd (rktio_std_fd rktio (stdio-log-receiver-which lr)))
105    (define bstr (bytes-append (string->bytes/utf-8 (vector-ref msg 1)) #"\n"))
106    (define len (bytes-length bstr))
107    (let loop ([i 0])
108      (define v (rktio_write_in rktio fd bstr i len))
109      (unless (rktio-error? v)
110        (let ([i (+ i v)])
111          (unless (= i len)
112            (loop i)))))
113    (rktio_forget rktio fd)))
114
115(define (add-stdio-log-receiver! who logger args parse-who which)
116  (check who logger? logger)
117  (define lr (stdio-log-receiver (parse-filters parse-who args #:default-level 'none)
118                                 rktio
119                                 which))
120  (atomically
121   (add-log-receiver! logger lr #f)
122   (set-logger-permanent-receivers! logger (cons lr (logger-permanent-receivers logger)))))
123
124(define/who (add-stderr-log-receiver! logger . args)
125  (add-stdio-log-receiver! who logger args 'make-stderr-log-receiver RKTIO_STDERR))
126
127(define/who (add-stdout-log-receiver! logger . args)
128  (add-stdio-log-receiver! who logger args 'make-stdio-log-receiver RKTIO_STDOUT))
129
130;; ----------------------------------------
131
132(struct syslog-log-receiver log-receiver (rktio cmd)
133  #:property
134  prop:receiver-send
135  (lambda (lr msg)
136    ;; called in atomic mode and possibly in host interrupt handler
137    (define rktio (syslog-log-receiver-rktio lr))
138    (define bstr (bytes-append (string->bytes/utf-8 (vector-ref msg 1)) #"\n"))
139    (define pri
140      (case (vector-ref msg 0)
141        [(fatal) RKTIO_LOG_FATAL]
142        [(error) RKTIO_LOG_ERROR]
143        [(warning) RKTIO_LOG_WARNING]
144        [(info) RKTIO_LOG_INFO]
145        [else RKTIO_LOG_DEBUG]))
146    (rktio_syslog rktio pri #f bstr (syslog-log-receiver-cmd lr))))
147
148(define/who (add-syslog-log-receiver! logger . args)
149  (define lr (syslog-log-receiver (parse-filters 'make-syslog-log-receiver args #:default-level 'none)
150                                  rktio
151                                  (path-bytes (find-system-path 'run-file))))
152  (atomically
153   (add-log-receiver! logger lr #f)
154   (set-logger-permanent-receivers! logger (cons lr (logger-permanent-receivers logger)))))
155
156;; ----------------------------------------
157
158(define (add-log-receiver! logger lr backref)
159  (atomically/no-interrupts/no-wind
160   ;; Add receiver to the logger's list, pruning empty boxes
161   ;; every time the list length doubles (roughly):
162   (cond
163     [(zero? (logger-prune-counter logger))
164      (set-logger-receiver-box+backrefs! logger
165                                         (cons (cons (make-weak-box lr) backref)
166                                               (for/list ([b+r (in-list (logger-receiver-box+backrefs logger))]
167                                                          #:when (weak-box-value (car b+r)))
168                                                 b+r)))
169      (set-logger-prune-counter! logger (max 8 (length (logger-receiver-box+backrefs logger))))]
170     [else
171      (set-logger-receiver-box+backrefs! logger (cons (cons (make-weak-box lr) backref)
172                                                      (logger-receiver-box+backrefs logger)))
173      (set-logger-prune-counter! logger (sub1 (logger-prune-counter logger)))])
174   ;; Increment the timestamp, so that wanted levels will be
175   ;; recomputed on demand:
176   (define ts-box (logger-root-level-timestamp-box logger))
177   (set-box! ts-box (add1 (unbox ts-box)))
178   ;; Post a semaphore to report that wanted levels may have
179   ;; changed:
180   (define sema-box (logger-level-sema-box logger))
181   (when (unbox sema-box)
182     (semaphore-post (unbox sema-box))
183     (set-box! sema-box #f))))
184
185;; Called in atomic mode and with interrupts disabled
186(define (log-receiver-send! r msg in-interrupt?)
187  (if (or (not in-interrupt?)
188          ;; We can run stdio loggers in atomic/interrupt mode:
189          (stdio-log-receiver? r))
190      ((receiver-send-ref r) r msg)
191      ;; Record any any other message for posting later:
192      (unsafe-add-pre-poll-callback! (lambda ()
193                                       ((receiver-send-ref r) r msg)))))
194
195;; ----------------------------------------
196
197(define (receiver-add-topics r topics default-level)
198  (let loop ([filters (log-receiver-filters r)] [topics topics])
199    (cond
200      [(pair? filters)
201       (loop (cdr filters) (hash-set topics (caar filters) #t))]
202      [else
203       (values topics (level-max default-level filters))])))
204