source: project/release/3/logging/trunk/logging.scm @ 9139

Last change on this file since 9139 was 9139, checked in by Kon Lovett, 12 years ago

Fix for e-mail uri query processing. Cosmetic chgs.

File size: 39.8 KB
Line 
1;;;; logging.scm
2;;;; Kon Lovett, Sep '06
3
4;; Issues
5;;
6;; - No ability to update/extend fields of a log object.
7;;
8;; (log-attach log #:echos #:alternates #:asynch)
9;;
10;; - Better formatting objects: Raw, XTerm_Color, VT100_Color, ...
11;;
12;; - Should lock log object at start of process rather than piecemeal.
13;;
14;; - Should unify log+alternates, echos & asynch as Appenders?
15;;
16;; - Sources & entries in logs for allowed items checking.
17;;
18;;              - Trying w/o entries since a pain in practice.
19;;
20;; - No mapping of source, fields to syslog entry components. Mapping of
21;; levels is kludgy.
22;;
23;; - No log file permissions.
24;;
25;; - No localization.
26;;
27;; - Should explicitly close all open log ports at shutdown.
28;;
29;; - A field can be a procedure; so must serialize. But serialize doesn't preserve
30;; identity so xref of log -> entry/source/level & entry -> field/level will duplicate
31;; the items; i.e. the one in the catalog will not be the same object as the previously
32;; xref'ed.
33;;
34;;              - Grouping all catalog dictionaries in a single record type.
35
36(eval-when (compile)
37  (declare
38        (usual-integrations)
39        (fixnum)
40        (inline)
41                (no-procedure-checks)
42                (no-bound-checks)
43        (bound-to-procedure
44                        fields->strings
45                        pid-field)
46        (export
47                make-log-mail-string
48                        make-logbook-operations
49                        make-logbook-source
50                        make-logbook-field
51                        make-logbook-level
52                        make-logbook-entry
53                        clone-logbook-entry
54                        make-logbook
55                        clone-logbook
56                        new-logbook-source
57                        new-logbook-field
58                        new-logbook-level
59                        new-logbook-entry
60                        clone-new-logbook-entry
61                        new-logbook
62                        clone-new-logbook
63                        logbook-level
64                        set-logbook-level!
65                        logbook-level-mask
66                        set-logbook-level-mask!
67                        %make-log-string
68                        make-log-string
69                        open-logbook
70                        close-logbook
71                        %log-string
72                        log-string
73                        log-message
74                        log-format ) ) )
75
76(use srfi-1 srfi-13 srfi-18 utils posix extras regex)
77(use lookup-table synch
78     misc-extn-list misc-extn-posix misc-extn-dsssl
79     miscmacros mailbox mathh-int uri smtp)
80(use logging-errors logging-catalogs logging-operations logging-parameters)
81
82;;;
83
84#+unix
85#>
86#include <syslog.h>
87#include <stdarg.h>
88
89static int syslog_level = LOG_INFO;
90/*static int syslog_facility = LOG_USER;*/
91
92static void
93syslog_set_level( int level/*, int source*/ )
94{
95    switch (level) {
96      case 0:   syslog_level = LOG_EMERG; break;
97      case 1:   syslog_level = LOG_ALERT; break;
98      case 2:   syslog_level = LOG_CRIT; break;
99      case 3:   syslog_level = LOG_ERR; break;
100      case 4:   syslog_level = LOG_WARNING; break;
101      case 5:   syslog_level = LOG_NOTICE; break;
102      case 6:   syslog_level = LOG_INFO; break;
103      case 7:   syslog_level = LOG_DEBUG; break;
104      default:  syslog_level = LOG_INFO; break;
105    }
106}
107
108static int
109syslog_str( const char *str )
110{
111    syslog( syslog_level | LOG_USER, "%s", str );
112    return 1;
113}
114<#
115
116;;;
117
118(include "logging-constants")
119(include "logging-record-types")
120(include "logging-argument-checking")
121
122;;; Constants
123
124;; Should use current locale (use srfi-19?)
125
126(define *month-abbreviations*
127        '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
128                 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
129
130;;; Record Types
131
132;;
133
134(define (make-source id mutable? name)
135        (let ([source (%make-source id mutable? name)])
136                (%source-mutex-set! source (make-mutex id))
137                source ) )
138
139(define-record-printer (source x out)
140        (fprintf out "#,(source ~S ~S ~S)"
141                (%source-id x)
142                (%source-mutable? x)
143                (%source-name x)) )
144
145(define-reader-ctor 'source
146  (lambda (id mutable? name)
147    (make-source id mutable? name)))
148
149;;
150
151(define (make-level id mutable? name priority)
152        (let ([level (%make-level id mutable? name priority)])
153                (%level-mutex-set! level (make-mutex id))
154                level ) )
155
156(define-record-printer (level x out)
157        (fprintf out "#,(level ~S ~S ~S ~S)"
158                (%level-id x)
159                (%level-mutable? x)
160                (%level-name x)
161                (%level-priority x)) )
162
163(define-reader-ctor 'level
164  (lambda (id mutable? name priority)
165    (make-level id mutable? name priority)))
166
167(define-inline (level<=? l1 l2)
168        (<= (%level-priority l1) (%level-priority l2)) )
169
170;;
171
172(define (make-field id mutable? value)
173        (let ([field (%make-field id mutable? value)])
174                (%field-mutex-set! field (make-mutex id))
175                field ) )
176
177(define-record-printer (field x out)
178        (fprintf out "#,(field ~S ~S ~S)"
179                (%field-id x)
180                (%field-mutable? x)
181                (%field-value x)) )
182
183(define-reader-ctor 'field
184  (lambda (id mutable? value)
185    (make-field id mutable? value)))
186
187;;
188
189(define (make-entry id mutable? indent level fields)
190        (let ([entry (%make-entry id mutable? indent level fields)])
191                (%entry-mutex-set! entry (make-mutex id))
192                entry ) )
193
194(define-record-printer (entry x out)
195        (fprintf out "#,(entry ~S ~S ~S ~S ~S)"
196                (%entry-id x)
197                (%entry-mutable? x)
198                (%entry-indent x)
199                (%entry-level x)
200                (%entry-fields x)) )
201
202(define-reader-ctor 'entry
203  (lambda (id mutable? indent level fields)
204    (make-entry id mutable? indent level fields)))
205
206(define (clone-entry entry id mutable? indent level fields)
207        (synch/entry entry
208                (make-entry id
209                        (optional-entry-value entry mutable?)
210                        (optional-entry-value entry indent)
211                        (optional-entry-value entry level)
212                        (optional-entry-value entry fields)) ) )
213
214;;
215
216(define (make-logbook-operations open close write)
217        (check-procedure open 'make-logbook-operations)
218        (check-procedure close 'make-logbook-operations)
219        (check-procedure write 'make-logbook-operations)
220        (%make-logbook-operations open close write) )
221
222(define-record-printer (logbook-operations x out)
223        (fprintf out "#,(logbook-operations ~S ~S ~S)"
224                (%logbook-operations-open x)
225                (%logbook-operations-close x)
226                (%logbook-operations-write x)) )
227
228(define-reader-ctor 'logbook-operations
229  (lambda (open close write)
230    (let ([foo
231            (lambda args
232              (error 'logbook-operations "cannot recover from read-syntax"))])
233      (make-logbook-operations foo foo foo))))
234
235;;
236
237(define (uri-encode-path uri)
238  (uri-encode-split-path (uri-path uri)) )
239
240(define-inline (%log-uri-or-pathname-set! log pathname)
241        (%log-uri-set! log #f)
242        (when pathname
243                (let* ([obj (uri pathname)]
244                                         [scheme (uri-scheme obj)])
245                        (when scheme
246                                (case scheme
247                                        [(file)
248                                                (%log-pathname-set! log (uri-encode-path obj))]
249                                        [else
250                                                (%log-pathname-set! log #f)
251                                                (%log-uri-set! log obj)])))) )
252
253(define (make-log id
254                                        mutable?
255                                        pathname
256                                        sources
257                                        entry level
258                                        echos alternates
259                                        keep-open? immediate-open?
260                                        operations
261                                        asynchronous? asynchronous-error)
262        (let ([log
263          (%make-log id
264            mutable?
265            pathname
266            (delete-duplicates sources eq?)
267            entry level
268            (delete-duplicates echos eq?)
269            (delete-duplicates alternates eq?)
270            keep-open?
271            immediate-open?
272            operations
273            asynchronous?
274            asynchronous-error)])
275                (%log-uri-or-pathname-set! log pathname)
276                (%log-session-open-set! log #f)
277                (%log-port-set! log #f)
278                (%log-mutex-set! log (make-mutex id))
279                (%log-fielder-set! log fields->strings)
280                (%log-level-mask-set! log '())
281                log ) )
282
283(define-record-printer (log x out)
284        (fprintf out "#,(log ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S)"
285                (%log-id x)
286                (%log-mutable? x)
287                (%log-pathname x)
288                (%log-uri x)
289                (%log-sources x)
290                (%log-entry x)
291                (%log-level x)
292                (%log-level-mask x)
293                (%log-echos x)
294                (%log-alternates x)
295                (%log-keep-open? x)
296                (%log-immediate-open? x)
297                (%log-operations x)
298                (%log-asynchronous? x)
299                (%log-asynchronous-error x)
300                (%log-fielder x)) )
301
302(define-reader-ctor 'log
303  (lambda (id mutable? pathname _uri sources entry level level-mask
304           echos alternates keep-open? immediate-open? operations
305           asynchronous? asynchronous-error fielder)
306    (let ([log
307            (make-log id
308              mutable?
309              pathname
310              sources
311              entry level
312              echos alternates
313              keep-open? immediate-open?
314              operations
315              asynchronous? asynchronous-error)])
316      (%log-level-mask-set! log level-mask)
317      log)))
318
319(define-inline (make-default-pathname)
320        (make-pathname (default-logbook-directory) "" (default-logbook-extension)) )
321
322(define (clone-pathname log cpn)
323        (let (
324                        [lpn (if (%log-uri log) (make-default-pathname) (%log-pathname log))])
325                (let-values (
326                                ([ldir lfil lext] (decompose-pathname lpn))
327                                ([cdir cfil cext] (decompose-pathname cpn)))
328                        (make-pathname (or cdir ldir) cfil (or cext lext))) ) )
329
330(define (clone-log log id
331                                        mutable?
332                                        pathname
333                                        sources
334                                        entry level
335                                        echos alternates
336                                        keep-open? immediate-open?
337                                        operations
338                                        asynchronous? asynchronous-error)
339        (%synch/log log
340                (make-log id
341                        (optional-log-value log mutable?)
342                        (and pathname (clone-pathname log pathname))
343                        (optional-log-value log sources)
344                        (optional-log-value log entry)
345                        (optional-log-value log level)
346                        (optional-log-value log echos)
347                        (optional-log-value log alternates)
348                        (optional-log-value log keep-open?)
349                        (optional-log-value log immediate-open?)
350                        (optional-log-value log operations)
351                        (optional-log-value log asynchronous?)
352                        (optional-log-value log asynchronous-error)) ) )
353
354(define (logable-level? log level)
355        (and (level<=? (%log-level log) level)
356       (let ([mask (%log-level-mask log)])
357         (or (null? mask)
358             (member level mask)))) )
359
360;;; Argument Checking
361
362;;
363
364(define (check-atom-or-list-of proc obj loc)
365        (if (list? obj)
366      (for-each (cut proc <> loc) obj)
367      (proc obj loc)) )
368
369(define (check-optional proc obj loc)
370        (unless (undefined? obj)
371                (proc obj loc)) )
372
373(define (check-boolean obj loc)
374        (unless (boolean? obj)
375                (log$error loc "invalid boolean" obj)) )
376
377(define (check-symbol obj loc)
378        (unless (symbol? obj)
379                (log$error loc "invalid symbol" obj)) )
380
381(define (check-string obj loc)
382        (unless (string? obj)
383                (log$error loc "invalid string" obj)) )
384
385(define (check-strings obj loc)
386        (check-atom-or-list-of check-string obj loc) )
387
388(define (check-procedure obj loc)
389        (unless (procedure? obj)
390                (log$error loc "invalid procedure" obj)) )
391
392#;
393(define (check-directory obj loc)
394        (unless (%directory-argument? obj)
395                (log$error loc "invalid directory name" obj)) )
396
397#;
398(define (check-filename obj loc)
399        (unless (%filename-argument? obj)
400                (log$error loc "invalid filename" obj)) )
401
402#;
403(define (check-extension obj loc)
404        (unless (%extension-argument? obj)
405                (log$error loc "invalid pathname extension" obj)) )
406
407(define (check-pathname-argument obj loc)
408        (unless (or (not obj) (string? obj))
409                (log$error loc "invalid pathname" obj)) )
410
411;;
412
413(define (check-field obj loc)
414        (unless (field-value? obj)
415                (log$error loc "invalid logbook field" obj)) )
416
417(define (check-fields obj loc)
418        (check-atom-or-list-of check-field obj loc) )
419
420(define (check-operations obj loc)
421        (unless (%logbook-operations? obj)
422                (log$error loc "invalid logbook operations" obj) ) )
423
424(define (check-indent obj loc)
425        (unless (and (fixnum? obj) (not (negative? obj)) (<= obj MAXIMUM-INDENT))
426                (log$error loc "invalid indent" obj)) )
427
428;;
429
430(define (check-source-argument obj loc)
431        (unless (%source-argument? obj)
432                (log$error loc "invalid logbook source" obj)) )
433
434(define (check-level-argument obj loc)
435        (unless (%level-argument? obj)
436                (log$error loc "invalid logbook level" obj)) )
437
438(define (check-entry-argument obj loc)
439        (unless (%entry-argument? obj)
440                (log$error loc "invalid logbook entry" obj)) )
441
442(define (check-log-argument obj loc)
443        (unless (%log-argument? obj)
444                (log$error loc "invalid logbook" obj)) )
445
446(define (check-logs-argument obj loc)
447        (check-atom-or-list-of check-log-argument obj loc) )
448
449(define (check-sources-argument obj loc)
450        (check-atom-or-list-of check-source-argument obj loc) )
451
452(define (check-levels-argument obj loc)
453        (check-atom-or-list-of check-level-argument obj loc) )
454
455;;
456
457(define (verify-source-for-sources source sources)
458        (unless (undefined? source)
459                (or (string? source)
460                        (memq source sources)) ) )
461
462(define (verify-source-for-log log source)
463        (%synch/log log
464                (verify-source-for-sources source (%log-sources log)) ) )
465
466(define (verify-level-for-entry entry level)
467        (unless (or (undefined? entry) (undefined? level))
468                (%synch/entry entry
469                        (eq? level (%entry-level entry)) ) ) )
470
471;;
472
473(define (check-source-for-log log source loc)
474        (unless (verify-source-for-log log source)
475                (log$error loc "invalid source for log" source log) ) )
476
477(define (check-level-for-entry entry level loc)
478        (unless (verify-level-for-entry entry level)
479                (log$error loc "invalid level for entry" level entry) ) )
480
481;;; Argument Resolution
482
483;;
484
485(define (most-specific-entry-item entry ref item default-item)
486        (if (or (not item) (undefined? item))
487      (or (and (not (undefined? entry))
488               (%synch/entry entry (ref entry)))
489          default-item)
490      item ) )
491
492(define (most-specific-log log ref logs default-logs)
493        (%synch/log log
494                (delete-duplicates!
495                        (append (ref log) (optional-value logs default-logs))
496                        eq?) ) )
497
498;;
499
500(define (most-specific-level entry level default-level)
501        (most-specific-entry-item entry
502                (lambda (entry) (%entry-level entry))
503                level default-level) )
504
505(define (most-specific-fields entry fields default-fields)
506        (most-specific-entry-item entry
507                (lambda (entry) (%entry-fields entry))
508                fields default-fields) )
509
510(define (most-specific-echos log echos default-echos)
511        (most-specific-log log
512                (lambda (log) (%log-echos log))
513                echos default-echos) )
514
515(define (most-specific-alternates log alternates default-alternates)
516        (most-specific-log log
517                (lambda (log) (%log-alternates log))
518                alternates default-alternates) )
519
520;;
521
522(define (resolve-object cat obj)
523        (if (symbol? obj)
524      (log$catalog-value cat obj)
525      obj ) )
526
527(define (resolve-objects proc obj)
528        (cond [(pair? obj)        (map proc obj)]
529        [(list? obj)        obj]
530        [(undefined? obj)   obj]
531        [else               (list (proc obj))] ) )
532
533;;
534
535(define (resolve-log-object obj)
536        (resolve-object log$log-catalog->log obj) )
537
538(define (resolve-entry-object obj)
539        (resolve-object log$entry-catalog->entry obj) )
540
541(define (resolve-level-object obj)
542        (resolve-object log$level-catalog->level obj) )
543
544(define (resolve-source-object obj)
545        (resolve-object log$source-catalog->source obj) )
546
547(define (resolve-log-objects obj)
548        (resolve-objects resolve-log-object obj) )
549
550(define (resolve-source-objects obj)
551        (resolve-objects resolve-source-object obj) )
552
553(define (resolve-entry-objects obj)
554        (resolve-objects resolve-entry-object obj) )
555
556(define (resolve-level-objects obj)
557        (resolve-objects log$level-catalog->level obj) )
558
559;;; Builtin Fields
560
561(define pid-field
562        (let ([pidstr #f])
563                (lambda ()
564                        (unless pidstr
565                                (set! pidstr (string-append "[" (number->string (current-process-id)) "]")) )
566                        pidstr ) ) )
567
568(define hostname-field
569        ; Can't cache the result, it could be changed.
570        get-host-name)
571
572(define (timestamp-field)
573        (let* (
574                        [timvec (seconds->local-time (current-seconds))]
575                        [monstr (vector-ref *month-abbreviations* (vector-ref timvec 4))]
576                        [intstr
577                                (lambda (idx prefix)
578                                        (let* ([itm (vector-ref timvec idx)]
579                                                                 [itmstr (number->string itm)])
580                                                (if (< itm 10)
581                (string-append/shared prefix itmstr)
582                itmstr ) ) )])
583                (string-append/shared
584                        monstr " " (number->string (vector-ref timvec 3))
585                        " "
586                        (intstr 2 "0") ":" (intstr 1 "0") ":" (intstr 0 "0")) ) )
587
588;;;
589
590(define (force-open-log log loc)
591        (let ([errors (log$make-errors)])
592                (unless (log$log-force-open log errors)
593                        (log$errors loc "cannot open log file" (errors)) ) ) )
594
595(define (force-close-log log loc)
596        (let ([errors (log$make-errors)])
597                (unless (log$log-force-close log errors)
598                        (log$errors loc "cannot close log file" (errors)) ) ) )
599
600;;; Create Logger Objects
601
602(define (make-logbook-pathname fil
603                                        #!key
604                                        (dir (default-logbook-directory))
605                                        (ext (default-logbook-extension)))
606        (make-pathname dir fil ext) )
607
608(define (make-logbook-source id #!optional (name (undefined-value)))
609        ;
610        (check-symbol id 'make-logbook-source)
611        (check-optional check-string name 'make-logbook-source)
612        ;
613        (make-source id #f (optional-value name (symbol->string id))) )
614
615(define (make-logbook-level id #!optional (priority 0) (name (undefined-value)))
616        ;
617        (check-symbol id 'make-logbook-level)
618        (check-optional check-string name 'make-logbook-level)
619        ;
620        (make-level id #f (optional-value name (symbol->string id)) priority) )
621
622(define (make-logbook-field id #!optional (value (undefined-value)))
623        ;
624        (check-symbol id 'make-logbook-field)
625        (check-optional check-field value 'make-logbook-field)
626        ;
627        (when (undefined? value)
628                (let ([proc (symbol-value id)])
629                        (check-procedure proc 'make-logbook-field)
630                        (set! value proc) ) )
631        ;
632        (make-field id #f value) )
633
634(define (make-logbook-entry id #!rest fields
635                                        #!key
636                                        (mutable? #f)
637                                        (indent 0)
638                                        (level (default-entry-level)))
639        ;
640        (set! fields
641              (fixup-extended-lambda-list-rest '(#:level #:indent #:mutable?)
642                                               fields))
643        ;
644        (check-symbol id 'make-logbook-entry)
645        (check-fields fields 'make-logbook-entry)
646        (check-level-argument level 'make-logbook-entry)
647        (check-indent indent 'make-logbook-entry)
648        ;
649        (make-entry id
650                mutable?
651                indent
652                (resolve-level-object level)
653                (or (not-null? fields) (default-entry-fields))) )
654
655(define (clone-logbook-entry entry id #!rest fields
656                                        #!key
657                                        (mutable? #f)
658                                        (indent (undefined-value))
659                                        (level (undefined-value)))
660        ;
661        (set! fields
662              (fixup-extended-lambda-list-rest '(#:level #:indent #:mutable?)
663                                               fields))
664        ;
665        (check-symbol id 'clone-logbook-entry)
666        (check-optional check-fields fields 'clone-logbook-entry)
667        (check-optional check-level-argument level 'clone-logbook-entry)
668        (check-optional check-indent indent 'clone-logbook-entry)
669        ;
670        (clone-entry (resolve-entry-object entry) id
671                mutable?
672                indent
673                (resolve-level-object level)
674                (if (null? fields)
675                    (undefined-value)
676                    fields)) )
677
678(define (make-logbook id
679                                        #!key
680                                        (mutable? #f)
681                                        (pathname (undefined-value))
682                                        (sources (default-logbook-sources))
683                                        (entry (default-logbook-entry))
684                                        (level (default-logbook-level))
685                                        (echos (default-logbook-echos))
686                                        (alternates (default-logbook-alternates))
687                                        (keep-open? #f)
688                                        (immediate-open? #f)
689                                        (operations log$*operations*)
690                                        (asynchronous? #f)
691                                        (asynchronous-error (undefined-value)))
692        ;
693        (check-symbol id 'make-logbook)
694        (check-boolean mutable? 'make-logbook)
695        (when (undefined? pathname)
696                (set! pathname (make-logbook-pathname (symbol->string id))))
697        (check-pathname-argument pathname 'make-logbook)
698        (check-boolean keep-open? 'make-logbook)
699        (check-boolean immediate-open? 'make-logbook)
700        (check-logs-argument alternates 'make-logbook)
701        (check-logs-argument echos 'make-logbook)
702        (check-sources-argument sources 'make-logbook)
703        (check-entry-argument entry 'make-logbook)
704        (check-level-argument level 'make-logbook)
705        (check-operations operations 'make-logbook)
706        (check-boolean asynchronous? 'make-logbook)
707        (check-optional check-procedure asynchronous-error 'make-logbook)
708        ;
709        (set! entries (resolve-entry-objects entries))
710        (set! entry (resolve-entry-object entry))
711        ;
712        (let ([log
713          (make-log id
714            mutable?
715            pathname
716            (resolve-source-objects sources)
717            entry
718            (resolve-level-object level)
719            (resolve-log-objects echos) (resolve-log-objects alternates)
720            keep-open? immediate-open?
721            operations
722            asynchronous? asynchronous-error)])
723                (when (%log-immediate-open? log)
724                        (force-open-log log 'make-logbook) )
725                log ) )
726
727(define (clone-logbook log id
728                                        #!key
729                                        (mutable? #f)
730                                        (pathname (undefined-value))
731                                        (sources (undefined-value))
732                                        (entry (undefined-value))
733                                        (level (undefined-value))
734                                        (echos (undefined-value))
735                                        (alternates (undefined-value))
736                                        (keep-open? (undefined-value))
737                                        (immediate-open? (undefined-value))
738                                        (operations (undefined-value))
739                                        (asynchronous? (undefined-value))
740                                        (asynchronous-error (undefined-value)))
741        ;
742        (check-log-argument log 'clone-logbook)
743        (check-symbol id 'clone-logbook)
744        (check-boolean mutable? 'clone-logbook)
745        (set! pathname (optional-value pathname (symbol->string id)))
746        (check-pathname-argument pathname 'clone-logbook)
747        (check-optional check-boolean keep-open? 'clone-logbook)
748        (check-optional check-boolean immediate-open? 'clone-logbook)
749        (check-optional check-logs-argument alternates 'clone-logbook)
750        (check-optional check-logs-argument echos 'clone-logbook)
751        (check-optional check-sources-argument sources 'clone-logbook)
752        (check-optional check-entry-argument entry 'clone-logbook)
753        (check-optional check-level-argument level 'clone-logbook)
754        (check-optional check-boolean asynchronous? 'clone-logbook)
755        (check-optional check-procedure asynchronous-error 'clone-logbook)
756        ;
757        (let ([clone
758          (clone-log (resolve-log-object log) id
759            mutable?
760            pathname
761            (resolve-source-objects sources)
762            (resolve-entry-object entry)
763            (resolve-level-object level)
764            (resolve-log-objects echos) (resolve-log-objects alternates)
765            keep-open? immediate-open?
766            operations
767            asynchronous? asynchronous-error)])
768                (when (%log-immediate-open? clone)
769                        (force-open-log clone 'clone-logbook))
770                clone ) )
771
772;;; Create Logger Objects In Catalog
773
774(define (new-logbook-source id . args)
775        (let ([source (apply make-logbook-source id args)])
776                (log$catalog-add! log$source-catalog->source id source 'new-logbook-source)
777                source ) )
778
779(define (new-logbook-field id . args)
780        (let ([field (apply make-logbook-field id args)])
781                (log$catalog-add! log$field-catalog->field id field 'new-logbook-field)
782                field ) )
783
784(define (new-logbook-level id . args)
785        (let ([level (apply make-logbook-level id args)])
786                (log$catalog-add! log$level-catalog->level id level 'new-logbook-level)
787                level ) )
788
789(define (new-logbook-entry id . args)
790        (let ([entry (apply make-logbook-entry id args)])
791                (log$catalog-add! log$entry-catalog->entry id entry 'new-logbook-entry)
792                entry ) )
793
794(define (clone-new-logbook-entry entry id . args)
795        (let ([entry (apply clone-logbook-entry entry id args)])
796                (log$catalog-add! log$entry-catalog->entry id entry 'clone-new-logbook-entry)
797                entry ) )
798
799(define (new-logbook id . args)
800        (let ([log (apply make-logbook id args)])
801                (log$catalog-add! log$log-catalog->log id log 'new-logbook)
802                log ) )
803
804(define (clone-new-logbook log id . args)
805        (let ([clone (apply clone-logbook log id args)])
806                (log$catalog-add! log$log-catalog->log id clone 'clone-new-logbook)
807                clone ) )
808
809;;; Special Logs
810
811;; console
812
813(define (create-console-log)
814        (new-logbook 'console
815                #:pathname "/dev/console"
816                #:echos '()
817                #:alternates '()
818                #:keep-open? #f) )
819
820;; syslog
821
822#+unix
823(define (create-system-log)
824        (new-logbook-entry 'system-message '(? source " ") '(? level " "))
825        (let (
826                        [log
827                                (new-logbook 'system
828                                        #:pathname #f
829                                        #:entry 'system-message
830                                        #:echos '()
831                                        #:alternates '()
832                                        #:keep-open? #t
833                                        #:operations
834                                                (make-logbook-operations
835                                                        (lambda (pathname errors)
836                                                                #t )
837                                                        (lambda (port errors)
838                                                                #t )
839                                                        (lambda (port str errors)
840                                                                ($ bool syslog_str (c-string str)) ) ) )])
841                ; A kludge
842                (%log-fielder-set! log
843                        (lambda (source level fields)
844                                (let (
845                                                [ilvl
846                                                        (case (%level-id level)
847                                                                [(emergency)  0]
848                                                                [(alert)      1]
849                                                                [(critical)   2]
850                                                                [(error)      3]
851                                                                [(warning)    4]
852                                                                [(notice)     5]
853                                                                [(info)       6]
854                                                                [(debug)      7]
855                                                                [else         6])])
856                                        ($ syslog_set_level (int ilvl))
857                                        (fields->strings source level fields)))) ) )
858
859;; stderr
860
861(define (create-error-log)
862        (new-logbook 'error
863                #:pathname #f
864                #:echos '()
865                #:alternates '()
866                #:keep-open? #t
867                #:operations
868                        (make-logbook-operations
869                                (lambda (pathname errors)
870                                        (current-error-port) )
871                                (lambda (port errors)
872                                        ;FIXME this is probably not a good idea
873                                        (close-output-port port)
874                                        #t )
875                                (%logbook-operations-write log$*operations*))) )
876
877;; Object Slot Access
878
879(define (logbook-level log)
880        (check-log-argument log 'logbook-level)
881        (%log-level (resolve-log-object log)) )
882
883(define (set-logbook-level! log level)
884        (check-log-argument log 'set-logbook-level!)
885        (check-level-argument level 'set-logbook-level!)
886        (%log-level-set! (resolve-log-object log) (resolve-level-object level)) )
887
888(define (logbook-level-mask log)
889        (check-log-argument log 'logbook-level-mask)
890        (%log-level-mask (resolve-log-object log)) )
891
892(define (set-logbook-level-mask! log . levels)
893        (check-log-argument log 'set-logbook-level-mask!)
894        (check-levels-argument levels 'set-logbook-level-mask!)
895        (%log-level-mask-set! (resolve-log-object log) (resolve-level-objects levels)) )
896
897;;; Message Construction
898
899(define indent->string
900        (let ([spcstr (make-string (* MAXIMUM-INDENT MAXIMUM-INDENT-AMOUNT) #\space)])
901                (lambda (indent)
902                        (if (positive? indent)
903          (substring/shared spcstr 0 (* indent (current-logbook-indent-amount)))
904          "") ) ) )
905
906(define-inline (level->string level)
907        (if (%level? level)
908      (%level-name level)
909      level ) )
910
911(define-inline (source->string source)
912        (if (%source? source)
913      (%source-name source)
914      source ) )
915
916(define (field->string source level field)
917        (let fld->str ([field field])
918                (cond [(string? field)
919            field]
920          [(%field? field)
921            (fld->str (%field-value field))]
922          [(symbol? field)
923            (case field
924              [(source)
925                (source->string source)]
926              [(level)
927                (level->string level)]
928              [else
929                (let ([fld (log$catalog-ref log$field-catalog->field field)])
930                  (if fld
931                      (fld->str fld)
932                      (symbol->string field) ) )] )]
933          [(procedure? field)
934            (field)]
935          [(length>1? field)
936            (case (car field)
937              [(quote)
938                (symbol->string (cadr field))]
939              [(?)
940                (let* ([args (cdr field)]
941                       [str (fld->str (car args))])
942                  (if (string-null? str)
943                      str
944                      (apply string-append/shared str (map fld->str (cdr args))) ) ) ]
945              [else
946                (->string field)] )]
947          [else
948            (->string field)]) ) )
949
950(define (fields->strings source level fields)
951        (cond [(null? fields)
952                ""]
953        [(pair? fields)
954          (map (cut field->string source level <>) fields)]
955        [else
956          (list (field->string source level fields))] ) )
957
958;; (%make-log-string 0 "" "" '() str ...)
959
960(define (%make-log-string log indent source level fields . msgs)
961        (%synch/log log
962                (string-concatenate/shared
963                        `(,(indent->string indent)
964                                ,@((%log-fielder log) source level fields)
965                                ,@msgs)) ) )
966
967(define (*make-log-string log entry indent source level fields msgs loc)
968        ;
969        (check-level-for-entry entry level loc)
970        ;
971        (apply %make-log-string
972                log
973                (optional-entry-value entry indent)
974                source
975                level
976                (most-specific-fields entry fields (default-logbook-fields))
977                msgs) )
978
979(define (make-log-string #!rest msgs
980                                        #!key
981                                        (entry (undefined-value))
982                                        (indent 0)
983                                        (source (undefined-value))
984                                        (level (undefined-value))
985                                        (fields (undefined-value)))
986        (let ([log #f])
987                ;
988                (set! msgs
989                      (fixup-extended-lambda-list-rest '(#:indent #:entry #:source #:level #:fields)
990                                                       msgs))
991                        ;
992                        (if (and (pair? msgs) (%log-argument? (car msgs)))
993          (begin
994            (set! log (car msgs))
995            (set! msgs (pop! msgs)) )
996          (set! log (default-logbook)) )
997                ;
998                (check-log-argument log 'log-string)
999                (check-optional check-entry-argument entry 'make-log-string)
1000                (check-indent indent 'make-log-string)
1001                (check-optional check-source-argument source 'make-log-string)
1002                (check-optional check-level-argument level 'make-log-string)
1003                (check-optional check-fields fields 'make-log-string)
1004                (check-strings msgs 'make-log-string)
1005                ;
1006                (set! entry (resolve-entry-object entry))
1007                ;
1008                (*make-log-string (resolve-log-object log) entry
1009                        indent
1010                        (resolve-source-object
1011                                (optional-value source (default-logbook-source)))
1012                        (resolve-level-object
1013                                (most-specific-level entry level (default-logbook-level)))
1014                        fields msgs
1015                        'make-log-string) ) )
1016
1017;;; URI
1018
1019(define (make-log-mail-string log str)
1020        (let ([obj (%log-uri log)]
1021                                [mail-line-break "\r\n"])
1022                (if obj
1023        (let ([al (uri-query obj)]
1024              [from #f]
1025              [subject #f]
1026              [bdy '()]
1027              [make-mail-header-line
1028                (lambda (key val)
1029                  (string-append
1030                    (string-titlecase (->string key))
1031                    ": "
1032                    (->string val)
1033                    mail-line-break))])
1034          (let ([hdr
1035                  (map
1036                    (lambda (pair)
1037                      (let ([key (car pair)]
1038                            [val (cdr pair)])
1039                        (cond [(string=? "body" key)
1040                                (set! body
1041                                      (cons (string-append (cdr pair) mail-line-break) body))
1042                                ""]
1043                              [(string=? "from" key)
1044                                (set! from (cdr pair))
1045                                ""]
1046                              [(string=? "subject" key)
1047                                (set! subject (cdr pair))
1048                                ""]
1049                              [else
1050                                (make-mail-header-line key val)])))
1051                    (or al '()))])
1052            (values
1053              (string-split (uri-encode-path obj) ",")
1054              (or from (%log-id log))
1055              (string-append
1056                (list->string hdr)
1057                (make-mail-header-line "subject" (or subject str))
1058                mail-line-break
1059                (list->string bdy)
1060                (if subject "" (string-append str mail-line-break))) ) ) )
1061        (values '() "" "") ) ) )
1062
1063(define (log$mail-uri-handler log str errors)
1064        (let ([obj (%log-uri log)])
1065          ; Note that authority is not actually part of the mailto std RFC2368.
1066                (let ([auth (or (uri-authority obj) (default-mail-authority))])
1067                        (if auth
1068          (let ([host (second auth)]
1069                [port (third auth)])
1070            (let (
1071                [smtpc
1072                  (smtp:connect
1073                    host (get-host-name)
1074                    #f (or port DEFAULT-SMTP-PORT))])
1075              (let-values ([(tos from cntnts) (make-log-mail-string log str)])
1076                (with-output-to-port (apply smtp:open smtpc from tos)
1077                  (lambda () (display cntnts)))
1078                (smtp:disconnect smtpc)
1079                #t ) ) )
1080          (begin
1081            (errors 'mail-uri-handler "missing authority")
1082            #f) ) ) ) )
1083
1084;;; Asynchronous Logging
1085
1086(define asynchronous-logger-start! #f)
1087(define asynchronous-logger-send! #f)
1088(define asynchronous-logger-stop! #f)
1089
1090(let ([asynchronous-logger-thread #f])
1091
1092        (define (asynchronous-logger)
1093                (let ([todo (mailbox-receive! (thread-specific (current-thread)))])
1094                        (let ([action (car todo)]
1095                                                [args (cdr todo)])
1096                                (case action
1097                                        [(quit)
1098                                                (void)]
1099                                        [(write)
1100                                                (let ([errors (log$make-errors)])
1101                                                        (let* ([log-args (cdr args)]
1102                                                                                 [log (car log-args)])
1103                                                                (unless (apply log$log-string log errors (cdr log-args))
1104                                                                        ((car args)
1105                                                                                (log$make-errors-condition
1106                                                                                        'asynchronous-logger "problem with log file" log (errors))) ) ) )
1107                                                (asynchronous-logger)]
1108                                        [else
1109                                                (log$error (thread-name (current-thread)) "unknown operation" todo)]) ) ) )
1110
1111        (set! asynchronous-logger-start!
1112                (lambda ()
1113                        (set! asynchronous-logger-thread
1114                                (make-thread asynchronous-logger 'asynchronous-logger))
1115                        (thread-specific-set! asynchronous-logger-thread
1116                                (make-mailbox 'asynchronous-logger-todo))
1117                        (thread-start! asynchronous-logger-thread) ) )
1118
1119        (set! asynchronous-logger-send!
1120                (lambda (obj)
1121                        (mailbox-send! (thread-specific asynchronous-logger-thread) obj) ) )
1122
1123        (set! asynchronous-logger-stop!
1124                (lambda ()
1125                        (asynchronous-logger-send! '(quit))
1126                        (thread-join! asynchronous-logger-thread) ) ) )
1127
1128;;; Logbook Write
1129
1130(define (%log-string log str
1131                                        #!optional
1132                                        (echos '())
1133                                        (alternates '())
1134                                        (open? #t)
1135                                        (asynchronous? #f)
1136                                        (asynchronous-error (undefined-value)))
1137        ;
1138        (if asynchronous?
1139      (asynchronous-logger-send!
1140        (list
1141          'write
1142          (optional-value asynchronous-error (default-asynchronous-error))
1143          log str echos alternates open?))
1144      (let ([errors (log$make-errors)])
1145        (unless (log$log-string log errors str echos alternates open?)
1146          (log$errors '%log-string "problem with log file" log (errors)) ) ) ) )
1147
1148;; (log-string (str|log) (str|null) ...)
1149
1150(define (log-string str #!rest args
1151                                        #!key
1152                                        (source (undefined-value))
1153                                        (level (undefined-value))
1154                                        (echos (undefined-value))
1155                                        (alternates (undefined-value))
1156                                        (open? #t)
1157                                        (asynchronous? #f)
1158                                        (asynchronous-error (undefined-value)))
1159        ;
1160        (let ([log #f])
1161                ;
1162                (set! args
1163                      (fixup-extended-lambda-list-rest '(#:source #:level #:echos #:alternates #:open?)
1164                                                       args))
1165                ;
1166                (if (%log-argument? str)
1167        (begin
1168          (set! log str)
1169          (if (null? args)
1170              (log$error 'log-string "missing message")
1171              (set! str (pop! args)) ) )
1172        (set! log (default-logbook)) )
1173                ;
1174                (check-log-argument log 'log-string)
1175                (set! log (resolve-log-object log))
1176                ;
1177                (check-optional check-source-argument source 'log-string)
1178                (check-source-for-log log
1179                        (resolve-source-object
1180                                (optional-value source (default-logbook-source)))
1181                        'log-string)
1182                ;
1183                (check-optional check-level-argument level 'log-string)
1184                (when (logable-level? log
1185                                                (resolve-level-object
1186                                                        (optional-value level (default-logbook-level))))
1187                        ;
1188                        (check-string str 'log-string)
1189                        (check-optional check-procedure asynchronous-error 'log-string)
1190                        (check-optional check-logs-argument echos 'log-string)
1191                        (check-optional check-logs-argument alternates 'log-string)
1192                        (check-boolean open? 'log-string)
1193                        (check-boolean asynchronous? 'log-string)
1194                        ;
1195                        (%log-string log
1196                                str
1197                                (most-specific-echos log
1198                             (resolve-log-objects echos)
1199                             (default-logbook-echos))
1200                                (most-specific-alternates log
1201                                  (resolve-log-objects alternates)
1202                                  (default-logbook-alternates))
1203                                open?
1204                                (optional-log-value log asynchronous?)
1205                                (optional-log-value log asynchronous-error)) ) ) )
1206
1207;;
1208
1209(define (*log-message log msg entry indent source level fields echos alternates open? asynchronous? asynchronous-error loc)
1210        ;
1211        (check-log-argument log loc)
1212        (set! log (resolve-log-object log))
1213        ;
1214        (check-optional check-entry-argument entry loc)
1215        (set! entry
1216                (resolve-entry-object (optional-value entry (%log-entry log))))
1217        ;
1218        (check-optional check-level-argument level loc)
1219        (set! level
1220                (resolve-level-object
1221                        (most-specific-level entry level (default-logbook-level))))
1222        ;
1223        (when (logable-level? log level)
1224                ;
1225                (check-optional check-source-argument source loc)
1226                (set! source
1227                        (resolve-source-object
1228                                (optional-value source (default-logbook-source))))
1229                (check-source-for-log log source loc)
1230                ;
1231                (check-string msg loc)
1232                (check-indent indent loc)
1233                (check-boolean open? loc)
1234                (check-optional check-fields fields loc)
1235                (check-optional check-logs-argument echos loc)
1236                (check-optional check-logs-argument alternates loc)
1237                (check-optional check-boolean asynchronous? loc)
1238                (check-optional check-procedure asynchronous-error loc)
1239                ;
1240                (%log-string log
1241                        (*make-log-string log entry indent source level fields (list msg) loc)
1242                        (most-specific-echos log
1243                           (resolve-log-objects echos)
1244                           (default-logbook-echos))
1245                        (most-specific-alternates log
1246                                (resolve-log-objects alternates)
1247                                (default-logbook-alternates))
1248                        open?
1249                        (optional-log-value log asynchronous?)
1250                        (optional-log-value log asynchronous-error)) ) )
1251
1252;; (log-message (msg|log) (msg|null) ...)
1253
1254(define (log-message msg #!rest fields
1255                                        #!key
1256                                        (entry (undefined-value))
1257                                        (indent 0)
1258                                        (source (undefined-value))
1259                                        (level (undefined-value))
1260                                        (echos (undefined-value))
1261                                        (alternates (undefined-value))
1262                                        (open? #t)
1263                                        (asynchronous? (undefined-value))
1264                                        (asynchronous-error (undefined-value)))
1265        ;
1266        (let ([log #f])
1267                ;
1268                (set! fields
1269                      (fixup-extended-lambda-list-rest
1270                       '(#:entry #:indent #:source #:level #:echos #:alternates
1271                         #:open? #:asynchronous? #:asynchronous-error)
1272                       fields))
1273                ;
1274                (if (%log-argument? msg)
1275        (begin
1276          (set! log msg)
1277          (if (null? fields)
1278              (log$error 'log-message "missing message")
1279              (set! msg (pop! fields)) ) )
1280        (set! log (default-logbook)) )
1281                ;
1282                (*log-message log
1283                        msg
1284                        entry
1285                        indent source level
1286                        (if (null? fields) (undefined-value) fields)
1287                        echos alternates
1288                        open?
1289                        asynchronous? asynchronous-error
1290                        'log-message) ) )
1291
1292;; (log-format (format-string|log) (format-string|null) ...)
1293
1294(define (log-format format-string #!rest args
1295                                        #!key
1296                                        (entry (undefined-value))
1297                                        (indent 0)
1298                                        (fields (undefined-value))
1299                                        (source (undefined-value))
1300                                        (level (undefined-value))
1301                                        (echos (undefined-value))
1302                                        (alternates (undefined-value))
1303                                        (open? #t)
1304                                        (asynchronous? (undefined-value))
1305                                        (asynchronous-error (undefined-value)))
1306        ;
1307        (let ([log #f])
1308                ;
1309                (set! args
1310                      (fixup-extended-lambda-list-rest
1311                       '(#:entry #:indent #:fields #:source #:level #:echos #:alternates
1312                         #:open? #:asynchronous? #:asynchronous-error)
1313                       args))
1314                ;
1315                (if (%log-argument? format-string)
1316        (begin
1317          (set! log format-string)
1318          (if (null? args)
1319            (log$error 'log-format "missing format-string")
1320            (set! format-string (pop! args)) ) )
1321        (set! log (default-logbook)) )
1322                ;
1323                (check-string format-string 'log-format)
1324                ;
1325                (*log-message log
1326                        (apply (current-logbook-format-procedure) #f format-string args)
1327                        entry
1328                        indent source level fields
1329                        echos alternates
1330                        open?
1331                        asynchronous? asynchronous-error
1332                        'log-format) ) )
1333
1334;;; Logbook Open/Close
1335
1336(define (open-logbook log)
1337        (check-log-argument log 'open-logbook)
1338        (force-open-log (resolve-log-object log) 'open-logbook) )
1339
1340(define (close-logbook log)
1341        (check-log-argument log 'close-logbook)
1342        (force-close-log (resolve-log-object log) 'close-logbook) )
1343
1344;;; Logger Initial State Build
1345
1346(define (initialize-logger)
1347        ;
1348        (log$empty-catalog)
1349        (logbook-uri-scheme-handler 'mailto log$mail-uri-handler)
1350        ;
1351        (new-logbook-source 'all "")
1352        (default-logbook-sources '(all))
1353        (default-logbook-source 'all)
1354        ;
1355        (new-logbook-level 'off         most-positive-fixnum  "")
1356        (new-logbook-level 'fatal       90                    "FATAL")
1357        (new-logbook-level 'emergency   80                    "EMERGENCY")
1358        (new-logbook-level 'alert       70                    "ALERT")
1359        (new-logbook-level 'critical    60                    "CRITICAL")
1360        (new-logbook-level 'error       50                    "ERROR")
1361        (new-logbook-level 'warning     40                    "WARNING")
1362        (new-logbook-level 'notice      30                    "NOTICE")
1363        (new-logbook-level 'info        20                    "INFO")
1364        (new-logbook-level 'debug       10                    "DEBUG")
1365        (new-logbook-level 'trace       0                     "TRACE")
1366        (new-logbook-level 'all         most-negative-fixnum  "")
1367        (default-logbook-level 'all)
1368        (default-entry-level 'all)
1369        ;
1370        (new-logbook-field 'source void)
1371        (new-logbook-field 'level void)
1372        (new-logbook-field 'pid pid-field)
1373        (new-logbook-field 'hostname hostname-field)
1374        (new-logbook-field 'timestamp timestamp-field)
1375        (default-logbook-fields '(timestamp " " (? source " ") (? level " ")))
1376        (default-entry-fields (default-logbook-fields))
1377        ;
1378        (new-logbook-entry 'message)
1379        (default-logbook-entries '(message))
1380        (default-logbook-entry 'message)
1381        ;
1382        (new-logbook 'message)
1383        (default-logbook 'message)
1384        ;
1385        (create-console-log)
1386        #+unix (create-system-log)
1387        (create-error-log)
1388        ;
1389        (asynchronous-logger-start!)
1390        (on-exit
1391                (lambda ()
1392                        (let/cc return
1393                                (with-exception-handler
1394                                        (lambda (exp)
1395                                                (return))
1396                                        (lambda ()
1397                                                (asynchronous-logger-stop!) ) ) ) ) ) )
1398
1399;;; Module Initialize
1400
1401(initialize-logger)
Note: See TracBrowser for help on using the repository browser.