;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.

(in-package #:syslog_helper)

(defun .one-of (choices)
  (apply #'smug:.or
	 (mapcar #'smug:.string=
		 choices)))

(defun .numeric-in-range (&key (min 0) max (min-inclusive t) max-inclusive)
  (let ((min-op (if min-inclusive #'<= #'<))
	(max-op (if max-inclusive #'>= #'>)))
    (smug:.let* ((num (smug:.first (smug:.map 'string (smug:.is #'digit-char-p)))))
      (let ((num (parse-integer num)))
	(if (and (funcall min-op min num)
		 (if max
		     (funcall max-op max num)
		     t))
	    (smug:.identity num)
	    (smug:.fail))))))

(defun .time ()
  (flet ((.min-sec ()
	     (.numeric-in-range :max 60))
	   (.hour ()
	     (.numeric-in-range :max 24)))
    (smug:.let* ((hour (smug:.prog1 (.hour)
				    (smug:.char= #\:)))
		 (minute (smug:.prog1 (.min-sec)
				      (smug:.char= #\:)))
		 (second (.min-sec)))
      (smug:.identity (format nil "~2,'0d:~2,'0d:~2,'0d" hour minute second)))))

(defun .timestamp ()
  (flet ((.month ()
	   (.one-of '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
		      "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
	 (.day ()
	   (.numeric-in-range :max 32)))
    (smug:.let* ((month (smug:.prog1 (.month)
				     (smug:.map 'list
						(smug:.char= #\space))))
		 (day (smug:.prog1 (.day)
				   (smug:.map 'list
					      (smug:.char= #\space))))
		 (time (.time)))
      (smug:.identity (format nil "~a ~a ~a" month day time)))))

(defun .hostname ()
  (smug:.prog1
   (smug:.first
    (smug:.map 'string
	       (smug:.or (smug:.char= #\.)
			 (smug:.is #'alphanumericp))))
   (smug:.char= #\space)))

(defun .tag ()
  (smug:.first
   (smug:.prog1
    (smug:.let* ((tag (smug:.optional (smug:.map 'string
						 (smug:.is #'alphanumericp))))
		 (process (smug:.optional
			   (smug:.prog2 (smug:.char= #\[)
					(smug:.map 'string (smug:.is #'digit-char-p))
					(smug:.char= #\])))))
      (if (> (length tag) 32)
	  (smug:.fail)
	  (smug:.identity (list (or tag "untagged")
				(when process
				  (parse-integer process))))))
    (smug:.optional (smug:.char= #\:)))))

(defun .dnsmasq-reply ()
  (smug:.progn (smug:.optional (smug:.char= #\space))
	       (.one-of '("cached " "reply " "/tmp/hosts/dhcp " "DHCP "))
	       (smug:.let* ((query (smug:.prog1 (smug:.map 'string
							   (smug:.or (smug:.char= #\-)
								     (smug:.char= #\_)
								     (smug:.char= #\.)
								     (smug:.is #'alphanumericp)))
						(smug:.string= " is ")))
			    (reply (smug:.prog1 (smug:.map 'string (smug:.item))
						(smug:.not (smug:.item)))))
		 (smug:.identity (list :query query
				       :reply reply)))))

(defun .dnsmasq-query ()
  (smug:.progn (smug:.optional (smug:.char= #\space))
	       (smug:.string= "query")
	       (smug:.let* ((query-type (smug:.prog2 (smug:.char= #\[)
						     (smug:.map 'string (smug:.is #'upper-case-p))
						     (smug:.char= #\])
						     (smug:.char= #\space)))
			    (query (smug:.prog1 (smug:.map 'string
							       (smug:.or (smug:.char= #\-)
									 (smug:.char= #\_)
									 (smug:.char= #\.)
									 (smug:.is #'alphanumericp)))
						    (smug:.string= " from ")))
			    (from (smug:.prog1 (smug:.map 'string (smug:.item))
					       (smug:.not (smug:.item)))))
		 (smug:.identity (list :query-type query-type
				       :query query
				       :from from)))))

(defstruct (priority (:type vector))
  facility severity)

(defun extract-priority (line)
  "Extract a priority from a syslog line and parse it into a severity/priority list"
  (when (char= (elt line 0)
	       #\<)
    (multiple-value-bind (result end) (parse-integer line :start 1 :junk-allowed t)
      (when (and (< end
		    (length line))
		 (char= (elt line end)
			#\>))
	(values (multiple-value-call #'vector
		  (floor result 8))
		(1+ end))))))

(defun parse-syslog (line)
  (multiple-value-bind (priority end-priority) (extract-priority line)
    (let ((line (subseq line end-priority)))
      (multiple-value-bind (timestamp ts-leftover) (smug:parse (smug:.optional (smug:.prog1 (.timestamp)
											    (smug:.map 'list
												       (smug:.char= #\space))))
							       line)
	(multiple-value-bind (hostname hn-leftover) (smug:parse (smug:.optional (.hostname)) ts-leftover)
	  (multiple-value-bind (tag-els leftover) (smug:parse (.tag) hn-leftover)
	    (handle-log-message (alexandria:make-keyword
				 (string-upcase (car tag-els)))
				(list :priority priority
				      :timestamp timestamp
				      :hostname hostname
				      :tag-value (car tag-els)
				      :tag-pid (cadr tag-els))
				leftover
				line)
	    (values (priority-facility priority)
		    (priority-severity priority)
		    tag-els
		    timestamp
		    leftover)))))))