;;;;
;;;; 215.stk		-- Implementation of SRFI-215
;;;;
;;;; Copyright © 2020 Jeronimo Pellegrini - <j_p@aleph0.info>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; This file is a derivative work from the  implementation of
;;;; this SRFI by Göran Weinholt, it is copyrighted as:
;;;;;;
;;;;;; © 2020 Göran Weinholt
;;;;;;
;;;;;; Permission is hereby granted, free of charge, to any person
;;;;;; obtaining a copy of this software and associated documentation files
;;;;;; (the "Software"), to deal in the Software without restriction,
;;;;;; including without limitation the rights to use, copy, modify, merge,
;;;;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;;;;; and to permit persons to whom the Software is furnished to do so,
;;;;;; subject to the following conditions:
;;;;;;
;;;;;; The above copyright notice and this permission notice (including the
;;;;;; next paragraph) shall be included in all copies or substantial
;;;;;; portions of the Software.
;;;;;;
;;;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;;;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;;;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;;;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;;;; SOFTWARE.
;;;;
;;;;           Author: Jeronimo Pellegrini [j_p@aleph0.info]
;;;;    Creation date: 16-Mar-2021 15:33 (jpellegrini)
;;;;


(define-module srfi/215
  (export
   send-log
   current-log-fields
   current-log-callback
   EMERGENCY ALERT CRITICAL ERROR WARNING NOTICE INFO DEBUG)

  
;; This queue code is based on public domain code from SLIB,
;; originally written by Andrew Wilcox in 1992. Here it has been
;; reduced in size and rewritten to use mutable pairs.

(define (make-queue)
  (cons '() '()))

(define (enqueue! q datum)
  (let ((new-pair (cons datum '())))
    (if (null? (car q))
        (set-car! q new-pair)
        (set-cdr! (cdr q) new-pair))
    (set-cdr! q new-pair)))

(define (dequeue! q)
  (let ((first-pair (car q)))
    (if (null? first-pair)
        (error 'enqueue! "attempt to dequeue an empty queue"))
    (let ((first-cdr (cdr first-pair)))
      (set-car! q first-cdr)
      (when (null? first-cdr)
        (set-cdr! q '()))
      (car first-pair))))

(define (queue-empty? q)
  (null? (car q)))

;; These severities are from RFC 5424 ("The Syslog Protocol").
(define EMERGENCY 0)                ; system is unusable
(define ALERT 1)                    ; action must be taken immediately
(define CRITICAL 2)                 ; critical conditions
(define ERROR 3)                    ; error conditions
(define WARNING 4)                  ; warning conditions
(define NOTICE 5)                   ; normal but significant condition
(define INFO 6)                     ; informational messages
(define DEBUG 7)                    ; debug-level messages

(define (field-list->alist plist)
  (let f ((fields plist))
    (cond ((null? fields)
           '())
          ((or (not (pair? fields)) (not (pair? (cdr fields))))
           (error 'field-list->alist "short field list ~S" plist))
          (else
           (let ((k (car fields)) (v (cadr fields)))
             (if (not v)
                 (f (cddr fields))
                 (let ((k^ (cond ((symbol? k) k)
                                 (else
                                  (error 'field-list->alist "invalid key -- bad symbol ~S" k))))
                       (v^ (cond ((string? v) v)
                                 ((and (integer? v) (exact? v)) v)
                                 ((bytevector? v) v)
                                 ;; ((condition?) v) ;R6RS
                                 ((error-object? v) v) ;R7RS
                                 (else
                                  (let ((p (open-output-string)))
                                    (write v p)
                                    (get-output-string p))))))
                   (cons (cons k^ v^)
                         (f (cddr fields))))))))))

(define current-log-fields
  (make-parameter '()
                  (lambda (plist)
                    (field-list->alist plist)
                    plist)))

(define current-log-callback
  (let ((num-pending-logs 0)
        (pending-logs (make-queue)))
    (make-parameter (lambda (log-entry)
                      (enqueue! pending-logs log-entry)
                      (if (eqv? num-pending-logs 100)
                          (dequeue! pending-logs)
                          (set! num-pending-logs (+ num-pending-logs 1))))
                    (lambda (hook)
                      (unless (procedure? hook)
                        (error 'current-log-hook "bad procedure ~S" hook))
                      (let ((q pending-logs))
                        (set! num-pending-logs 0)
                        (set! pending-logs (make-queue))
                        (let lp ()
                          (unless (queue-empty? q)
                            (hook (dequeue! q))
                            (lp))))
                      hook))))

;; Send a log entry with the given severity and message. This
;; procedure also takes a list of extra keys and values.
(define (send-log severity message . plist)
  (unless (and (integer? severity)
               (exact? severity)
               (<= 0 severity 7))
    (error 'send-log "severity -- bad integer ~S (should be between 0 and 7)"
           severity))
  (unless (string? message)
    (error 'send-log "message -- bad string ~S" message))
  (let* ((fields (append plist (current-log-fields)))
         (alist (field-list->alist fields)))
    ((current-log-callback) `((SEVERITY . ,severity)
                              (MESSAGE . ,message)
                              ,@alist))))

) ;; END OF DEFINE-MODULE
;;;; ======================================================================

(provide "srfi/215")
