; Copyright (c) 1993-2000 by Richard Kelsey and Jonathan Rees. See file COPYING.

;; Options for openlog

(define-finite-type syslog-option :syslog-option
  (mask)
  syslog-option?
  the-syslog-options
  syslog-option-name
  syslog-option-index
  (mask syslog-option-mask)
  ;; These values are known to the C code.
  ((console		#o01)
   (delay		#o02)
   (no-delay		#o04)
   (log-pid		#o10)))

(define-record-type syslog-options :syslog-options
  (really-make-syslog-options value)
  syslog-options?
  (value syslog-options-value))

(define syslog-options=? eq?)

(define-exported-binding "syslog-options-type" :syslog-options)

(define (syslog-options-on? options0 options1)
  (= 0 (bitwise-and (syslog-options-value options1)
		    (bitwise-not (syslog-options-value options0)))))

(define (make-syslog-options options)
  (really-make-syslog-options
   (apply bitwise-ior (map syslog-option-mask options))))

(define default-syslog-options (make-syslog-options '()))

(define (make-mask-record->list get-value get-mask record-vector)
  (lambda (mask-record)
    (let ((value (get-value mask-record))
	  (n-syslog-options (vector-length record-vector)))
      (let loop ((i 0) (list '()))
	(cond
	 ((>= i n-syslog-options)
	  list)
	 ((zero? (bitwise-and value
			      (get-mask (vector-ref record-vector i))))
	  (loop (+ 1 i) list))
	 (else
	  (loop (+ 1 i) (cons (vector-ref record-vector i)
			      list))))))))

(define syslog-options->list
  (make-mask-record->list syslog-options-value
			  syslog-option-mask
			  the-syslog-options))

; Simplifying syntax, e.g. (syslog-options delay console)

(define-syntax syslog-options
  (syntax-rules ()
    ((syslog-options name ...)
     (make-syslog-options (list (syslog-option name) ...)))))

(define-enumerated-type syslog-facility :syslog-facility
  syslog-facility?
  syslog-facilities
  syslog-facility-name
  syslog-facility-index
  ;; Options for openlog
  ;; The order of these is known to the C code.
  (authorization
   cron
   daemon
   kernel
   lpr
   mail
   news
   user
   uucp
   local0 local1 local2 local3 local4 local5 local6 local7))

(define syslog-facility=? eq?)

(define default-syslog-facility (syslog-facility user))

(define-exported-binding "syslog-facility-type" :syslog-facility)
(define-exported-binding "syslog-facilities" syslog-facilities)

(define-finite-type syslog-level :syslog-level
  (mask)
  syslog-level?
  syslog-levels
  syslog-level-name
  syslog-level-index
  (mask syslog-level-mask)
  ;; Options for syslog
  ;; The order and the values of these is known to the C code.
  ((emergency	#o001)
   (alert	#o002)
   (critical	#o004)
   (error	#o010)
   (warning	#o020)
   (notice	#o040)
   (info	#o100)
   (debug	#o200)))

(define syslog-level=? eq?)

(define-exported-binding "syslog-level-type" :syslog-level)
(define-exported-binding "syslog-levels" syslog-levels)

(define-record-type syslog-mask :syslog-mask
  (make-syslog-mask value)
  syslog-mask?
  (value syslog-mask-value))

(define (syslog-mask=? mask-1 mask-2)
  (= (syslog-mask-value mask-1)
     (syslog-mask-value mask-2)))

(define-exported-binding "syslog-mask-type" :syslog-mask)

(define (syslog-mask-levels-on? mask-1 mask-2)
  (= 0 (bitwise-and (syslog-mask-value mask-2)
		    (bitwise-not (syslog-mask-value mask-1)))))

(define (levels->syslog-mask levels)
  (make-syslog-mask
   (apply bitwise-ior
	  (map syslog-level-mask levels))))

(define syslog-mask->levels
  (make-mask-record->list syslog-mask-value
			  syslog-level-mask
			  syslog-levels))

(define-syntax syslog-mask
  (syntax-rules ()
    ((syslog-mask name ...)
     (levels->syslog-mask (list (syslog-level name) ...)))))

(define (syslog-mask-upto level)
  (let loop ((index (syslog-level-index level)) (levels '()))
    (if (< index 0)
	(levels->syslog-mask levels)
	(loop (- index 1) (cons index levels)))))

(define syslog-mask-all (levels->syslog-mask (vector->list syslog-levels)))

(define default-syslog-mask syslog-mask-all)

(import-lambda-definition openlog (ident options facility)
			  "sch_openlog")
(import-lambda-definition unix-syslog (level opt-facility message)
			  "sch_syslog")
(import-lambda-definition setlogmask! (logmask)
			  "sch_setlogmask")
(import-lambda-definition closelog ()
			  "sch_closelog")

(define-record-type syslog-channel :syslog-channel
  (make-syslog-channel ident options facility mask)
  syslog-channel?
  (ident syslog-channel-ident)
  (options syslog-channel-options)
  (facility syslog-channel-facility)
  (mask syslog-channel-mask))

(define (syslog-channel-equivalent? channel-1 channel-2)
  (and (string=? (syslog-channel-ident channel-1)
		 (syslog-channel-ident channel-2))
       (syslog-options=? (syslog-channel-options channel-1)
			 (syslog-channel-options channel-2))
       ;; facility can be specified with each syslog-write
       (syslog-mask=? (syslog-channel-mask channel-1)
		      (syslog-channel-mask channel-2))))

(define current-syslog-channel 'unitinialized)
(define current-syslog-channel-lock 'unitinialized)

(define (initialize-syslog)
  (set! current-syslog-channel #f)
  (set! current-syslog-channel-lock (make-lock)))

(define open-syslog-channel make-syslog-channel)

(define (close-syslog-channel channel)
  (obtain-lock current-syslog-channel-lock)
  (if (syslog-channel-equivalent? channel
				  current-syslog-channel)
      (closelog))
  (release-lock current-syslog-channel-lock))

;; THUNK must not escape
(define (with-syslog-channel channel thunk)
  (obtain-lock current-syslog-channel-lock)
  (if (or (not current-syslog-channel)
	  (not (syslog-channel-equivalent? channel
					   current-syslog-channel)))
      (begin
	(if current-syslog-channel
	    (closelog))
	(openlog (syslog-channel-ident channel)
		 (syslog-channel-options channel)
		 (syslog-channel-facility channel))
	(if (not (syslog-mask=? (syslog-channel-mask channel)
				default-syslog-mask))
	    (setlogmask! (syslog-channel-mask channel)))
	(set! current-syslog-channel channel)))
  (thunk)
  (release-lock current-syslog-channel-lock))

(define (syslog-write level message channel)
  (with-syslog-channel
   channel
   (lambda ()
     (unix-syslog level (syslog-channel-facility channel) message))))

(define (list-ref-carefully list n default)
  (cond
   ((null? list) default)
   ((zero? n) (car list))
   (else
    (list-ref-carefully (cdr list) (- n 1) default))))

(define (change-syslog-channel channel . rest)
  (let ((ident (list-ref-carefully rest 0 #f))
	(options (list-ref-carefully rest 1 #f))
	(facility (list-ref-carefully rest 2 #f))
	(mask (list-ref-carefully rest 3 #f)))
    (make-syslog-channel (or ident
			     (syslog-channel-ident channel))
			 (or options
			     (syslog-channel-options channel))
			 (or facility
			     (syslog-channel-facility channel))
			 (or mask
			     (syslog-channel-mask channel)))))

(define dynamic-syslog-channel
  (make-thread-fluid
   (make-syslog-channel "scheme48"
			default-syslog-options
			default-syslog-facility
			default-syslog-mask)))

(define (syslog level message . rest)
  (syslog-write level message
		(if (and (not (null? rest))
			 (null? (cdr rest))
			 (syslog-channel? (car rest)))
		    (car rest)
		    ;; this might be a little excessive allocation
		    (apply change-syslog-channel
			   (thread-fluid dynamic-syslog-channel)
			   rest))))

(define (with-syslog-destination ident options facility mask thunk)
  (let-thread-fluid dynamic-syslog-channel
		    (change-syslog-channel
		     (thread-fluid dynamic-syslog-channel)
		     ident options facility mask)
		    thunk))

;----------------
; A record type whose only purpose is to run some code when we start up an
; image.

(define-record-type reinitializer :reinitializer
  (make-reinitializer thunk)
  reinitializer?
  (thunk reinitializer-thunk))

(define-record-discloser :reinitializer
  (lambda (r)
    (list 'reinitializer (reinitializer-thunk r))))

(define-record-resumer :reinitializer
  (lambda (r)
    ((reinitializer-thunk r))))

(initialize-syslog)

(define syslog-reinitializer
  (make-reinitializer initialize-syslog))