|
| 1 | +;;; SRFI 215 |
| 2 | +;;; Central Log Exchange |
| 3 | +;;; |
| 4 | +;;; This SRFI specifies a central log exchange for Scheme that connects log producers |
| 5 | +;;; with log consumers. It allows multiple logging systems to interoperate and co-exist |
| 6 | +;;; in the same program. Library code can produce log messages without knowledge of |
| 7 | +;;; which log system is actually used. Simple applications can easily get logs on |
| 8 | +;;; standard output, while more advanced applications can send them to a full |
| 9 | +;;; logging system. |
| 10 | +;;; |
| 11 | +;;; Copyright © 2020 Göran Weinholt. All rights reserved. |
| 12 | +;;; |
| 13 | +;;; Permission is hereby granted, free of charge, to any person obtaining a copy of this |
| 14 | +;;; software and associated documentation files (the "Software"), to deal in the Software |
| 15 | +;;; without restriction, including without limitation the rights to use, copy, modify, merge, |
| 16 | +;;; publish, distribute, sublicense, and/or sell copies of the Software, and to permit |
| 17 | +;;; persons to whom the Software is furnished to do so, subject to the following conditions: |
| 18 | +;;; |
| 19 | +;;; The above copyright notice and this permission notice shall be included in all copies or |
| 20 | +;;; substantial portions of the Software. |
| 21 | +;;; |
| 22 | +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, |
| 23 | +;;; INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR |
| 24 | +;;; PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE |
| 25 | +;;; FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR |
| 26 | +;;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER |
| 27 | +;;; DEALINGS IN THE SOFTWARE. |
| 28 | +;;; |
| 29 | +;;; Adaptation to LispKit |
| 30 | +;;; Copyright © 2021 Matthias Zenger. All rights reserved. |
| 31 | + |
| 32 | +(define-library (srfi 215) |
| 33 | + |
| 34 | + (export send-log |
| 35 | + current-log-fields |
| 36 | + current-log-callback |
| 37 | + EMERGENCY |
| 38 | + ALERT |
| 39 | + CRITICAL |
| 40 | + ERROR |
| 41 | + WARNING |
| 42 | + NOTICE |
| 43 | + INFO |
| 44 | + DEBUG) |
| 45 | + |
| 46 | + (import (lispkit base)) |
| 47 | + |
| 48 | + (begin |
| 49 | + |
| 50 | + ;; This queue code is based on public domain code from SLIB, |
| 51 | + ;; originally written by Andrew Wilcox in 1992. Here it has been |
| 52 | + ;; reduced in size and rewritten to use mutable pairs. |
| 53 | + |
| 54 | + (define (make-queue) |
| 55 | + (mcons '() '())) |
| 56 | + |
| 57 | + (define (enqueue! q datum) |
| 58 | + (let ((new-pair (mcons datum '()))) |
| 59 | + (if (null? (mcar q)) |
| 60 | + (set-mcar! q new-pair) |
| 61 | + (set-mcdr! (mcdr q) new-pair)) |
| 62 | + (set-mcdr! q new-pair))) |
| 63 | + |
| 64 | + (define (dequeue! q) |
| 65 | + (let ((first-pair (mcar q))) |
| 66 | + (if (null? first-pair) |
| 67 | + (error "attempt to dequeue an empty queue")) |
| 68 | + (let ((first-cdr (mcdr first-pair))) |
| 69 | + (set-mcar! q first-cdr) |
| 70 | + (when (null? first-cdr) |
| 71 | + (set-mcdr! q '())) |
| 72 | + (mcar first-pair)))) |
| 73 | + |
| 74 | + (define (queue-empty? q) |
| 75 | + (null? (mcar q))) |
| 76 | + |
| 77 | + ;; These severities are from RFC 5424 ("The Syslog Protocol"). |
| 78 | + (define EMERGENCY 0) ; system is unusable |
| 79 | + (define ALERT 1) ; action must be taken immediately |
| 80 | + (define CRITICAL 2) ; critical conditions |
| 81 | + (define ERROR 3) ; error conditions |
| 82 | + (define WARNING 4) ; warning conditions |
| 83 | + (define NOTICE 5) ; normal but significant condition |
| 84 | + (define INFO 6) ; informational messages |
| 85 | + (define DEBUG 7) ; debug-level messages |
| 86 | + |
| 87 | + (define (field-list->alist plist) |
| 88 | + (let f ((fields plist)) |
| 89 | + (cond ((null? fields) |
| 90 | + '()) |
| 91 | + ((or (not (pair? fields)) (not (pair? (cdr fields)))) |
| 92 | + (error "short field list" plist)) |
| 93 | + (else |
| 94 | + (let ((k (car fields)) (v (cadr fields))) |
| 95 | + (if (not v) |
| 96 | + (f (cddr fields)) |
| 97 | + (let ((k^ (cond ((symbol? k) k) |
| 98 | + (else |
| 99 | + (error "invalid key" k plist)))) |
| 100 | + (v^ (cond ((string? v) v) |
| 101 | + ((and (integer? v) (exact? v)) v) |
| 102 | + ((bytevector? v) v) |
| 103 | + ;; ((condition?) v) ;R6RS |
| 104 | + ((error-object? v) v) ;R7RS |
| 105 | + (else |
| 106 | + (let ((p (open-output-string))) |
| 107 | + (write v p) |
| 108 | + (get-output-string p)))))) |
| 109 | + (cons (cons k^ v^) |
| 110 | + (f (cddr fields)))))))))) |
| 111 | + |
| 112 | + (define current-log-fields |
| 113 | + (make-parameter '() |
| 114 | + (lambda (plist) |
| 115 | + (field-list->alist plist) |
| 116 | + plist))) |
| 117 | + |
| 118 | + (define current-log-callback |
| 119 | + (let ((num-pending-logs 0) |
| 120 | + (pending-logs (make-queue))) |
| 121 | + (make-parameter (lambda (log-entry) |
| 122 | + (enqueue! pending-logs log-entry) |
| 123 | + (if (eqv? num-pending-logs 100) |
| 124 | + (dequeue! pending-logs) |
| 125 | + (set! num-pending-logs (+ num-pending-logs 1)))) |
| 126 | + (lambda (hook) |
| 127 | + (unless (procedure? hook) |
| 128 | + (error "current-log-hook: expected a procedure" hook)) |
| 129 | + (let ((q pending-logs)) |
| 130 | + (set! num-pending-logs 0) |
| 131 | + (set! pending-logs (make-queue)) |
| 132 | + (let lp () |
| 133 | + (unless (queue-empty? q) |
| 134 | + (hook (dequeue! q)) |
| 135 | + (lp)))) |
| 136 | + hook)))) |
| 137 | + |
| 138 | + ;; Send a log entry with the given severity and message. This |
| 139 | + ;; procedure also takes a list of extra keys and values. |
| 140 | + (define (send-log severity message . plist) |
| 141 | + (unless (and (exact? severity) (integer? severity) (<= 0 severity 7)) |
| 142 | + (error "send-log: expected a severity from 0 to 7" |
| 143 | + severity message plist)) |
| 144 | + (unless (string? message) |
| 145 | + (error "send-log: expected message to be a string" |
| 146 | + severity message plist)) |
| 147 | + (let* ((fields (append plist (current-log-fields))) |
| 148 | + (alist (field-list->alist fields))) |
| 149 | + ((current-log-callback) `((SEVERITY . ,severity) |
| 150 | + (MESSAGE . ,message) |
| 151 | + ,@alist)))) |
| 152 | + ) |
| 153 | +) |
0 commit comments