;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Sun Dec 17 15:21:13 2006 +0530 <enometh@net.meer>
;;;   Time-stamp: <2008-05-29 15:59:35 madhu>
;;;   Bugs-To: <enometh@net.meer>
;;;   Copyright (C) 2006-07  Madhu. All Rights Reserved.
;;;   Status: Experimental. Do not Redistribute
;;;   $Id: parse-syslog.lisp,v 1.2 2007/07/27 14:51:34 madhu Exp madhu $
;;;
(defpackage "PARSE-SYSLOG-1-1"
  (:use "CL")
  (:export
   "SYSLOG-MAP-LINES"))
(in-package "PARSE-SYSLOG-1-1")

;;;
;;;
(defun syslog-parse-date-positions (line &key (start 0) end)
  (declare (ignore line))
  (let* ((date-start start)
	 (date-end (+ date-start 15)))
    (when end (assert (<= date-end end)))
    (values date-start date-end)))

;;; FROM-BOL if Non-NIL indicates the whole line should be parsed.
;;;
(defun syslog-parse-host-positions (line &key (start 0) end from-bol)
  (let* ((host-start (if from-bol
			 (multiple-value-bind (date-start date-end)
			     (syslog-parse-date-positions line :start start :end end)
			   (declare (ignore date-start))
			   (assert (char= #\Space (char line date-end)))
			   (1+ date-end))
			 start))
	 (host-end (position #\Space line :start host-start :end end)))
    (when end (assert (<= host-end end)))
    (values host-start host-end)))

;;; If the first return value is NIL then the line doesnt have a
;;; process section and the last return value is the last position
;;; read.
;;;
(defun syslog-parse-process-positions (line &key (start 0) end from-bol)
  (let* ((process-name-start (if from-bol
				 (multiple-value-bind (host-start host-end)
				     (syslog-parse-host-positions line :start start :end end :from-bol from-bol)
				   (declare (ignore host-start))
				   (assert (char= #\Space (char line host-end)))
				   (1+ host-end))
				 start))
	 (process-end (position #\: line :start process-name-start :end end))
	 (x (if (null process-end)
		(return-from syslog-parse-process-positions ; XXX
		  (values NIL NIL NIL NIL PROCESS-NAME-START))
		(position #\[ line :start process-name-start :end process-end)))
	 (process-name-end (if x x process-end))
	 (process-number-start (if x (1+ x)))
	 (process-number-end (if x (1- process-end))))
    (when x (assert (char= (char line (1- process-end)) #\])))
    (values process-name-start process-name-end process-number-start
	    process-number-end process-end)))

;;;
;;;
(defun syslog-parse-message-positions (line &key (start 0) end from-bol)
  (let* ((message-line-start
	  (if from-bol
	      (multiple-value-bind (process-name-start
				    process-name-end
				    process-number-start
				    process-number-end
				    process-end)
		  (syslog-parse-process-positions line :start start :end end :from-bol from-bol)
		(declare (ignore PROCESS-NAME-END PROCESS-NUMBER-START PROCESS-NUMBER-END))
		(cond ((null process-name-start) process-end) ; XXX
		      (t (assert (char= (char line (1+ process-end)) #\Space))
			 (+ process-end 2))))
	      start))
	 (message-line-end (or end (length line))))
    (values message-line-start message-line-end)))

#||
(defvar $line
  "Nov 29 16:37:06 localhost pppd[18756]: Connect: ppp0 <--> /dev/pts/10")
;;;
;;;0123456789012345678901234567890123456789012345678901234567890123456789
;;;         10        20        30        40        50        60
;;;
(syslog-parse-date-positions $line)	;; => 0,15
(syslog-parse-host-positions $line :from-bol t)	;; => 16,25
(syslog-parse-message-positions $line :from-bol t) ;=> 39 69
(syslog-parse-message-positions "Dec 19 14:35:44 localhost last message repeated 9 times"
				:from-bol t) ;=> 26, 55
(syslog-parse-message-positions "Jan 20 12:03:10 localhost logger: bar" :from-bol t) ; 34 47
(syslog-parse-process-positions "Jan 20 12:03:10 localhost logger: bar" :from-bol t) ; 26 32 NIL NIL 32
||#


;;; ----------------------------------------------------------------------
;;;
;;; PARSE SYSLOG DATE USING TRIES
;;;
;;;
#+nil
(user::lc "home:cl/mytrie")

(defun month-variants (month-string &optional month-number)
  "Internal. Return uppercase downcase capitalized version of
MONTH-STRING and its 3 letter abbreviation."
  (let* ((canonical-string (string-capitalize (string-downcase month-string)))
	 (ret (list canonical-string)))
    (when (> (length canonical-string) 3)
      (let ((abbrev-string (subseq canonical-string 0 3)))
	(push abbrev-string ret)))
    (setq ret (nconc
	       (loop for string in ret
		     collect (string-upcase string)
		     collect (string-downcase string))
	       ret))
    (when month-number
      (check-type month-number (integer 1 12))
      (let ((month-number-string (princ-to-string month-number)))
	(push month-number-string ret)
	(when (< month-number 10)
	  (push (concatenate 'string "0" month-number-string) ret))))
    (nreverse ret)))

#+nil
(month-variants "January" 1)

(defvar *datetime-month-trie*
  (let ((trie (trie:make-trie)))
    (loop for (month-num . month-variants)
	  in (loop for monthnum from 1 to 12
		   for month-name in '("January" "February" "March"
				       "April" "May" "June" "July"
				       "August" "September"
				       "October" "November" "December")
		   collect (cons monthnum (month-variants month-name)))
	  do (loop for month-name in month-variants
		   do (setf (trie:gettrie month-name trie) month-num)))
    trie))

#||
(format nil "~v,'0,D" 2 1)
(trie:parse-identifier "Jan" *datetime-month-trie*) ;; => 1,3
(trie:parse-identifier "foo MAR" *datetime-month-trie* :start 4 :end 7);; => 3, 7
(trie:parse-identifier "Nov 29 16:37:06 localhost " *datetime-month-trie*) ;; => 11, 3
(time
 (loop for i below 1000
       do (trie:parse-identifier
	   "Nov 29 16:37:06 localhost " *datetime-month-trie*)))
; Evaluation took:
;   0.01 seconds of real time
;   0.012998 seconds of user run time
;   0.0 seconds of system run time
;   6,903,786 CPU cycles
;   0 page faults and
;   0 bytes consed.
;
||#

(defun date-variants (date)
  "Internal."
  (check-type date (integer 1 31))
  (let* ((date-string (princ-to-string date))
	 (ret (list date-string)))
    (when (< date 10)
      (push (concatenate 'string "0" date-string) ret)
      (push (concatenate 'string " " date-string) ret))
    ret))

#+nil
(date-variants 1)

(defvar *datetime-date-trie*
  (let ((trie (trie:make-trie)))
    (loop for (date . date-variants)
	  in (loop for date from 1 to 31
		   collect (cons date (date-variants date)))
	  do (loop for date-string in date-variants
		   do (setf (trie:gettrie date-string trie) date)))
    trie))

(defun hour-variants (hour)
  "Internal."
  (check-type hour (integer 0 23))
  (let* ((hour-string (princ-to-string hour))
	 (ret (list hour-string)))
    (when (< hour 10)
      (push (concatenate 'string "0" hour-string) ret))
    ret))

#+nil
(hour-variants 6)

(defvar *datetime-hour-trie*
  (let ((trie (trie:make-trie)))
    (loop for hour from 0 to 23
	  do (loop for x in (hour-variants hour)
		   do (setf (trie:gettrie x trie) hour)))
    trie))

;; An INSTANT is between 0-59

(defun instant-variants (instant)
  "Internal."
  (check-type instant (integer 0 59))
  (let* ((instant-string (princ-to-string instant))
	 (ret (list instant-string)))
    (when (< instant 10)
      (push (concatenate 'string "0" instant-string) ret))
    ret))

(defvar *datetime-instant-trie*
  (let ((trie (trie:make-trie)))
    (loop for instant from 0 to 59
	  do (loop for x in (instant-variants instant)
		   do (setf (trie:gettrie x trie) instant)))
    trie))

;;;
;;; XXX
;;;
(defvar *default-year* 2008)
(defvar *default-time-zone* -11/2)

(defun syslog-decode-date-string
    (line &key (start 0) end (year *default-year*) (time-zone *default-time-zone*))
  "Internal. Returns as values second minute hour date month year day nil
time-zone second-end. Last return value is the last position
read."
  (let* ((month-start start) (month-end (+ month-start 3))
	 (date-start (+ month-end 1)) (date-end (+ date-start 2))
	 (hour-start (+ date-end 1)) (hour-end (+ hour-start 2))
	 (minute-start (+ hour-end 1)) (minute-end (+ minute-start 2))
	 (second-start (+ minute-end 1)) (second-end (+ second-start 2)))
    (when end (assert (<= end second-end)))
    (multiple-value-bind (month x)
	(trie:parse-identifier line *datetime-month-trie* :start month-start :end month-end)
      (declare (type (integer 1 12) month))
      (assert month) (assert (= month-end x)) (assert (char= (char line month-end) #\Space))
      (multiple-value-bind (date x)
	  (trie:parse-identifier line *datetime-date-trie* :start date-start :end date-end)
	(declare (type (integer 1 31) date))
	(assert date) (assert (= date-end x)) (assert (char= (char line date-end) #\Space))
	(multiple-value-bind (hour x)
	    (trie:parse-identifier line *datetime-hour-trie* :start hour-start :end hour-end)
	  (declare (type (integer 0 23) hour))
	  (assert hour) (assert (= hour-end x)) (assert (char= (char line hour-end) #\:))
	  (multiple-value-bind (minute x)
	      (trie:parse-identifier line *datetime-instant-trie* :start minute-start :end minute-end)
	    (declare (type (integer 0 59) minute))
	    (assert minute) (assert (= minute-end x)) (assert (char= (char line minute-end) #\:))
	    (multiple-value-bind (second x)
		(trie:parse-identifier line *datetime-instant-trie* :start second-start :end second-end)
	      (declare (type (integer 0 59) second))
	      (assert second) (assert (= second-end x))
	      (values second minute hour date month year time-zone second-end))))))))

;;;
;;;
(defun syslog-parse-date (line &key (start 0) end (year *default-year*) (time-zone *default-time-zone*))
  (multiple-value-bind (second minute hour date month year time-zone second-end)
      (syslog-decode-date-string line :start start :end end :year year :time-zone time-zone)
    (values (encode-universal-time second minute hour date month year time-zone)
	    second-end)))

#||
(syslog-parse-date "Nov 29 16:37:06 localhost " :year 2006 :time-zone -11/2) ;; => 3373787226, 15
(syslog-parse-date "Jan  1 06:33:15 localhost" :year 2007 :time-zone -11/2) ;; => 3376602195, 15
(syslog-parse-date "Jan  3 00:19:15" :year 2007 :time-zone -11/2) ;; => 3376752555, 15
(syslog-parse-date "Nov 29 16:37:06 localhost " :year *default-year* :time-zone *default-time-zone*);; => 3405323226, 15
(time					; conses
 (loop for i below 1000 for x = (encode-universal-time 6 37 16 29 11 2006 -11/2) do (incf x)))
(= (syslog-parse-date "Nov 29 16:37:06 localhost " :year *default-year* :time-zone *default-time-zone*)
   (ext:parse-time "Nov 29 16:37:06 localhost " :default-zone *default-time-zone* :default-year *default-year* :end 15))
(time (loop for i below 10000
	    do (ext:parse-time "Nov 29 16:37:06 localhost "
			       :default-zone *default-time-zone*
			       :default-year *default-year*
			       :end 15)))
; Evaluation took:
;   1.04 seconds of real time
;   0.976851 seconds of user run time
;   0.037994 seconds of system run time
;   523,092,206 CPU cycles
;   0 page faults and
;   6,960,000 bytes consed.
(time (loop for i below 10000
	    do (syslog-parse-date "Nov 29 16:37:06 localhost ")))
; Evaluation took:
;   0.23 seconds of real time
;   0.216967 seconds of user run time
;   0.002999 seconds of system run time
;   115,320,848 CPU cycles
;   0 page faults and
;   560,000 bytes consed.
;
;; XXX cant eliminate consing here
||#


;;; ----------------------------------------------------------------------
;;;
;;;
(defvar *last-message-repeated-cookie* "last message repeated ")

#+nil
(length *last-message-repeated-cookie*)	; 22

(defvar *hostname-trie* (trie:make-trie))
(defvar *process-name-trie* (trie:make-trie))

(defun syslog-parse-line-f (line &optional f &key (start 0) end lineno)
  "Internal. Parse a single syslog LINE, and funcall F on the decomposed components."
  (let (host-name process-name process-number repeated)
    (multiple-value-bind (date-start date-end)
	(syslog-parse-date-positions line :start start :end end)
      (assert (char= #\Space (char line date-end)))
      (multiple-value-bind (host-start host-end)
	  (syslog-parse-host-positions line :start (1+ date-end) :end end)
	(assert (char= #\Space (char line host-end)))
	(setq host-name (trie:trie-set-identifier line *hostname-trie* :start host-start :end host-end))
	(multiple-value-bind (process-name-start
			      process-name-end
			      process-number-start
			      process-number-end
			      process-end)
	    (syslog-parse-process-positions line :start (1+ host-end) :end end)
	  (multiple-value-bind (message-line-start message-line-end)
	      (syslog-parse-message-positions
	       line :start
	       (cond (process-name-start
		      (assert (char= (char line (1+ process-end)) #\Space))
		      (setq process-name
			    (trie:trie-set-identifier line *process-name-trie*
						      :start process-name-start
						      :end process-name-end))
		      (setq process-number
			    (when process-number-start
			      (parse-integer line :start process-number-start :end process-number-end)))
		      (when repeated (setq repeated nil))
		      (+ process-end 2))
		     (t (assert (string= *last-message-repeated-cookie*
					 line :start2 process-end :end2 (+ process-end 22)
					 :start1 0 :end1 22))
			(setq repeated (parse-integer line :start (+ process-end 22) :junk-allowed t))
			process-end))
	       :end end)
	    (when f
	      (funcall f line
		       :start start
		       :end end
		       :lineno lineno
		       :date-start date-start
		       :date-end date-end
		       :host-name host-name
		       :process-name process-name
		       :process-number process-number
		       :repeated repeated
		       :message-start message-line-start
		       :message-end message-line-end))))))))

(defun syslog-map-lines (file &optional f)
  (with-open-file (stream file)
    (loop for lineno from 1
	  for line = (read-line stream nil nil)
	  while line do
	  (syslog-parse-line-f line f :lineno lineno))))

#||
(syslog-map-lines "/var/log/daemon.log") ;dry-run
(trie:trie-completions *process-name-trie*)
(trie::trie-count *hostname-trie*)
(trie::trie-count *process-name-trie*)
(let ((keys))
  (trie:maptrie (lambda (k v) (push k keys)) *process-name-trie*)
  (map-into keys (lambda (x) (coerce x 'string)) keys))
||#


;;; ----------------------------------------------------------------------
;;;
;;;  FILE-BUFFER (TODO RELOCATE)
;;;
(defstruct (file-buffer
	     (:constructor %make-file-buffer)
	     (:print-function
	      (lambda (obj stream depth)
		(declare (ignore depth)
			 (type stream stream))
		(print-unreadable-object (obj stream :type t :identity t)
		  (format stream "~D CHARS ~D LINES" (length (file-buffer-buffer obj))
			  (length (file-buffer-eol-vector obj)))))))
  "Stores the string contents of a file containing newline
  terminated lines, along with offsets."
  buffer eol-vector bol-vector)

(defmethod make-file-buffer ((buffer string))
  "Returns a FILE-BUFFER structure"
  (multiple-value-bind (eol-list size)
      (loop for p = nil then x
	    for x across buffer for i from 0
	    if (char= x #\Newline)
	    collect i into list and count 1 into size
	    finally (return (values list size)))
    (let ((eol-vector (make-array size :element-type '(integer 0)))
	  (bol-vector (make-array size :element-type '(integer 0))))
      (setf (aref bol-vector 0) 0)
      (loop for prev-eol = -1 then x for x in eol-list for i from 0
	    do (setf (aref bol-vector i) (1+ prev-eol)
		     (aref eol-vector i) x))
      (%make-file-buffer :buffer buffer
			 :eol-vector eol-vector
			 :bol-vector bol-vector))))

(defun get-line (file-buffer lineno &optional displaced-p)
  "Returns the line at position LINENO in FILE-BUFFER. If
DISPLACED-P is NIL, return a fresh string. Otherwise returns a
string displaced to the buffer stored in FILE-BUFFER."
  (declare (type file-buffer file-buffer)
	   (type (integer 0) lineno))
  (let ((buffer (file-buffer-buffer file-buffer))
	(start (aref (file-buffer-bol-vector file-buffer) lineno))
	(end (aref (file-buffer-eol-vector file-buffer) lineno)))
    (if displaced-p
	(make-array (- end start) :element-type (array-element-type buffer)
		    :displaced-to buffer :displaced-index-offset start)
	(subseq buffer start end))))

#||
(defvar $fb (make-file-buffer
	     (user::slurp-file "home:.bash_history" nil
			       :element-type 'character)))
(pprint $fb)
(get-line $fb 13 t)
||#


;;; ----------------------------------------------------------------------
;;;
;;; INTERN IP ADDRESS STRINGS IN A TRIE
;;;

(defvar *ip-address-table* (trie:make-trie))

(defun intern-ip-string (string &key (start 0) end)
  (let ((index 0) (num 0) (key nil))
    (declare (type fixnum index num))
    (labels ((err () (error "~S is not an IP address" (subseq string start end)))
	     (acc (n)
	       (declare (type fixnum n))
	       (setq num (+ n (* num 10)))
	       (unless (<= num 255) (err)))
	     (add (c)
	       (case c
		 (#\0) (#\1 (acc 1)) (#\2 (acc 2))
		 (#\3 (acc 3)) (#\4 (acc 4)) (#\5 (acc 5))
		 (#\6 (acc 6)) (#\7 (acc 7)) (#\8 (acc 8))  (#\9 (acc 9))
		 (#\. (push num key) (setq num 0) (incf index))
		 (otherwise (err)))))
      (loop for i from start below (or end (length string))
	    do (add (char string i))
	    finally
	    (unless (= index 3) (err))
	    (add #\.)))
    (or (trie:gettrie key *ip-address-table*)
	(setf (trie:gettrie key *ip-address-table*) (subseq string start end)))))

#+nil
(intern-ip-string "128.122.1.188.0" :end 13)


;;; ----------------------------------------------------------------------
;;;
;;; Example: SYSLOG-PPPD-PARSER
;;;

(defstruct (pppd-session (:constructor %make-pppd-session))
  index
  connected
  connection-terminated
  authentication
  local-ip
  remote-ip
  sent-bytes
  received-bytes
  connect-time
  closed-p
  lines)

;;;
;;; Accessor caches modify pppd-session-set-slot to take a
;;; hash-table on which it caches setf accessors.
;;;
;;; ;madhu 080529
;;;

(defvar *accessor-cache* nil
  "Hash-table which caches setf functions. Key is a symbol denoting the
accessor method.  Default value is NIL which indicates no caching.")

(defun make-setf-accessor-cache ()
  "Return a hash-table which caches setf functions. key is a symbol denoting
the accessor method."
  (make-hash-table :test #'eq))

(defun find-or-make-setter (accessor-symbol accessor-cache)
  (check-type accessor-symbol symbol)
  (or (gethash accessor-symbol accessor-cache)
      (setf (gethash accessor-symbol accessor-cache)
	    (multiple-value-bind
		  (vars vals store-vars writer-form reader-form)
		(get-setf-expansion (list accessor-symbol 'object))
	      (declare (ignore reader-form))
	      (warn "computing ~A" accessor-symbol)
	      (let* ((bindings
		      (nconc
		       (pairlis vars (mapcar 'list vals))
		       (pairlis store-vars (list '(new-value)))))
		     (form `(lambda (new-value object)
			      (let ,bindings ,writer-form))))
		(compile nil form))))))

(defun pppd-session-set-slot (pppd-session slot-accessor new-value
			      &optional (accessor-cache *accessor-cache*))
  "Internal. Sets the slot of PPPD-SESSION accessed by accessor
named SLOT-ACCESSOR to NEW-VALUE. If the slot is non-NIL, throws
a continuable error, after providing restarts for replacing the
original value.

ACCESSOR-CACHE is a hash-table where we cache accessors. This is the value of
the dynamic vafriable *ACCESSOR-CACHE*.
"
  (declare (type pppd-session pppd-session)
	   (type symbol slot-accessor))
  (prog ((orig-value (funcall slot-accessor pppd-session)))
     (when (or (null orig-value) (equalp orig-value new-value))
       (go setitandreturn))
     (restart-case
	 (error "Duplicate Entry for slot ~S encountered in pppd-session
~S:~&Old Value: ~S.~&New Value: ~S."
		slot-accessor pppd-session (funcall slot-accessor pppd-session)
		new-value)
       (ignore ()
	 :report "Keep original value."
	 (return nil))
       (replace ()
	 :report "Override with new value"
	 (go setitandreturn))
       (new-session ()
	 :report "Throw a \"Start a New Session\" condition."
	 (error 'start-new-session)))
     setitandreturn
     (return
       (let ((fdefn
	      (or
	       ;;(ignore-errors (fdefinition `(setf ,slot-accessor)))
	       (and accessor-cache
		    (find-or-make-setter slot-accessor accessor-cache))
	       (error "Could not find SETF method ~A" slot-accessor))))
	 (cond (fdefn
		(funcall fdefn new-value pppd-session))
	       ((multiple-value-bind	; XXX excise branch
		      (vars vals store-vars writer-form reader-form)
		    (get-setf-expansion (list slot-accessor pppd-session))
		  (declare (ignore reader-form))
		  (let* ((bindings
			  (nconc
			   (pairlis vars (mapcar 'list vals))
			   (pairlis store-vars (list (list new-value)))))
			 (form `(lambda () (let ,bindings ,writer-form))))
		    (funcall form)))))))))

;;;
;;;
(defvar +connected-message-prefix+ "Connect: ")	;madhu 080529
;; ppp0 <--> "  ==>  INTERFACE <--> DEVICE
(defvar +connection-terminated-message+ "Connection terminated.")
(defvar +authpap-indicator-message+ "PAP authentication succeeded")
(defvar +authchap-indicator-message+ "CHAP authentication succeeded")
(defvar +connect-time-message-prefix+ "Connect time")
(defvar +xfer-stats-message-prefix+ "Sent")
(defvar +local-ip-message-prefix+ "local  IP address")
(defvar +remote-ip-message-prefix+ "remote IP address")
(defvar +session-end-message+ "Exit.")

(defun %parse-xfer-stats (msg &key (start 0) end)
  "Internal. PPPD syslog parser."
  (multiple-value-bind (sent pos)
      (parse-integer msg :start (+ start 5) :end end :junk-allowed t)
    (loop while (char= (aref msg pos) #\Space) do (incf pos))
    (assert (string= "bytes, received " msg :start2 pos :end2 (+ pos 16)))
    (multiple-value-bind (received pos2)
	(parse-integer msg :start (+ pos 16) :end end :junk-allowed t)
      (loop while (char= (aref msg pos2) #\Space) do (incf pos2))
      (assert (string= "bytes." msg :start2 pos2))
      (values sent received))))

#+nil
(%parse-xfer-stats "Sent 58217 bytes, received 234001 bytes.")

(defun %parse-connect-time (msg &key (start 0) end)
  "Internal. PPPD syslog parser."
  (with-standard-io-syntax
    (let (*read-eval*)
      (multiple-value-bind (value pos)
	  (read-from-string msg t nil :end end
			    :start (+ start 1
				      (length +connect-time-message-prefix+))
			    :preserve-whitespace nil)
	(assert (string= "minutes." msg :start2 pos))
	(check-type value number)
	value))))

#+nil
(%parse-connect-time "Connect time 23.8 minutes.")

#+nil
(length +remote-ip-message-prefix+)	; 17

(defun %parse-remote-ip-address (line &key (start 0) end)
  "Internal. PPPD syslog parser."
  (intern-ip-string line :start (+ 1 start 17) :end end))

#+nil
(length +remote-ip-message-prefix+)	; 17

(defun %parse-local-ip-address (line &key (start 0) end)
  "Internal. PPPD syslog parser."
  (intern-ip-string line :start (+ 1 start 17) :end end))

;;;
;;;
(defun prefix-match (prefix string &key (start 0) end)
  "Return non NIL if PREFIX is a prefix of STRING delimited by
START and END."
  (let ((prefix-length (length prefix)))
    (when (< prefix-length (- (or end (length string)) start))
      (string= prefix string :start2 start :end2 (+ start prefix-length)))))

;;;
;;;
(defun string-match (match string &key (start 0) end)
  "Return non NIL if MATCH matches STRING delimited by START and
END."
  (let ((match-length (length match)))
    (when (= match-length (- (or end (length string)) start))
      (string= match string :start2 start :end2 (+ start match-length)))))

;;;
;;;
(defclass mydate () ((utime :initarg :utime :accessor utime)))

(defmethod print-object ((obj mydate) stream)
  (if (slot-boundp obj 'utime)
      (user:date :utime (slot-value obj 'utime) :stream stream)
      (print-unreadable-object (obj stream :type t :identity t))))

(defmacro syslog-parse-date1 (&rest args)
  `(let ((.x. (syslog-parse-date ,@args)))
     (when .x. (make-instance 'mydate :utime .x.))))

;;;
;;;
(defun pppd-session-set-slot-from-line (x line date-start date-end message-start message-end)
  "Internal. PPPD syslog parser. Extract a slot from line LINE
into PPPD-SESSION object X."
  (cond
    ((string-match +connection-terminated-message+ line :start message-start :end message-end)
     (pppd-session-set-slot x 'pppd-session-connection-terminated
			    (syslog-parse-date1 line :start date-start :end date-end)))
    ((prefix-match +connected-message-prefix+ line :start message-start :end message-end)
     (pppd-session-set-slot x 'pppd-session-connected
			    (syslog-parse-date1 line :start date-start :end date-end)))
    ((string-match +authpap-indicator-message+ line :start message-start :end message-end)
     (pppd-session-set-slot x 'pppd-session-authentication :pap))
    ((string-match +authchap-indicator-message+ line :start message-start :end message-end)
     (pppd-session-set-slot x 'pppd-session-authentication :chap))
    ((prefix-match +local-ip-message-prefix+ line :start message-start :end message-end)
     (pppd-session-set-slot x 'pppd-session-local-ip
			    (%parse-local-ip-address line :start message-start :end message-end)))
    ((prefix-match +remote-ip-message-prefix+ line :start message-start :end message-end)
     (pppd-session-set-slot x 'pppd-session-remote-ip
			    (%parse-remote-ip-address line :start message-start :end message-end)))
    ((prefix-match +connect-time-message-prefix+ line :start message-start :end message-end)
     (pppd-session-set-slot x 'pppd-session-connect-time
			    (%parse-connect-time line :start message-start :end message-end)))
    ((prefix-match +xfer-stats-message-prefix+ line :start message-start :end message-end)
     (multiple-value-bind (sent received) (%parse-xfer-stats line :start message-start :end message-end)
       (pppd-session-set-slot x 'pppd-session-sent-bytes sent)
       (pppd-session-set-slot x 'pppd-session-received-bytes received)))
    ((string-match +session-end-message+ line :start message-start :end message-end)
     (pppd-session-set-slot x 'pppd-session-closed-p t))
    #+NIL
    (t (warn "pppd-session-set-slot-from-line: ignoring line ~S." line))))

;;;
;;;
;;;
(defvar *pppd-sessions-table* (make-hash-table)
  "Each key is an integer PID. Value is a list of
PPPD-SESSION objects.")

(defvar *pppd-session-counter* 0
  "Internal. Next session ID to assign.")

(defvar *pppd-session-counter-tolerance* 10
  "Internal. If non-NIL must be a number.  Used during session creation, when
deciding to reuse an existing open session: If the latest session ID assigned
does not exceed the session ID of the open session by this magnitude, reuse
the open session.")

(defvar *pppd-reuse-session-pairs* nil
  "Internal. Used during session creation, when deciding to reuse an existing
open session, to mark a pid <=> session ID pair as OK to reuse.")

(defun pppd-initialize-session-creation
    (&optional	   ; XXX Use a bogus default to point to its docstring
     (tolerance *pppd-session-counter-tolerance* tolerance-supplied-p))
  (clrhash *pppd-sessions-table*)
  (when *accessor-cache* (clrhash *accessor-cache*))
  (setq *pppd-session-counter* 0)
  (setq *pppd-reuse-session-pairs* nil)
  (when tolerance-supplied-p
    (check-type tolerance (or null (integer 0)))
    (setq *pppd-session-counter-tolerance* tolerance)))

(defun pppd-session-get-create (process-number &optional new-session-p)
  "Returns an open session if found in *PPPD-SESSIONS-TABLE*, or creates a new
session interning it there.  Increments *PPPD-SESSION-COUNTER*.  If an open
session is found but the session ID differs from *PPPD-SESSION-COUNTER* by
more than *PPPD-SESSION-COUNTER-TOLERANCE*, raise a restartable error: the
user can choose to reuse the open session, or create a new session."
  (flet ((new-session ()
	   (car (push (%make-pppd-session
		       :index (prog1 *pppd-session-counter*
				(incf *pppd-session-counter*)))
		      (gethash process-number *pppd-sessions-table*)))))
    (if new-session-p
	(new-session)
	(let* ((pppd-sessions-list
		(gethash process-number *pppd-sessions-table*))
	       (pppd-session
		(if pppd-sessions-list (car pppd-sessions-list))))
	  (if (and pppd-session (not (pppd-session-closed-p pppd-session)))
	      (let ((pppd-session-index (pppd-session-index pppd-session)))
		(assert (> *pppd-session-counter* pppd-session-index))
		(if (and *pppd-session-counter-tolerance*
			 (> (- *pppd-session-counter* pppd-session-index)
			    *pppd-session-counter-tolerance*)
			 (not (find (cons process-number pppd-session-index)
				    *pppd-reuse-session-pairs*
				    :test #'equal)))
		    (restart-case
			(error "Suspicious log entry for PID ~D.
Next assignable Session ID: ~D
Open session with ID ~D exists:~&~S"
			       process-number
			       *pppd-session-counter*
			       pppd-session-index pppd-session)
		      (reuse ()
			:report "Reuse this session"
			(push (cons process-number pppd-session-index)
			      *pppd-reuse-session-pairs*)
			(return-from pppd-session-get-create pppd-session))
		      (new ()
			:report "Create a new session"
			(return-from pppd-session-get-create (new-session))))
		    pppd-session))
	      (new-session))))))

(define-condition start-new-session () ())

;;;
;;;
;;;
(defvar *check-host-name* "localhost"
  "Default value of hostname.  Currently we use this in CHECK-HOST-NAME to
ensure we are reading the correct file.")

(defun check-host-name (host-name)
  (tagbody
   loop
     (when *check-host-name*
       (restart-case
	   (unless (eq host-name
		       (trie:gettrie *check-host-name* *hostname-trie*))
	     (error "host-name ~A does not match *CHECK-HOST-NAME* ~A.
Use the USE-VALUE restart to set *CHECK-HOST-NAME* to a different value.
Set it to NIL to disable this check permanently."
		    host-name *check-host-name*))
	 (ignore-it ()
	   :report "Ignore and Continue")
	 (change-it (new-hostname)
	   :report "Enter a new value for *CHECK-HOST-NAME*."
	   :interactive
	   (lambda ()
	     (format t "Enter a new value for *CHECK-HOST-NAME*: ")
	     (multiple-value-list (eval (read))))
	   (if (stringp host-name)
	       (setq *check-host-name* new-hostname)
	       (warn "Ignoring non-string input: ~S" new-hostname))
	   (go loop))
	 (disable-it () ; (sets *CHECK-HOST-NAME* to NIL)
	   :report "Do not perform this check in the future."
	   (setq *check-host-name* nil)
	   (go loop))))))

(defun pppd1 (line &key host-name process-name process-number lineno date-start date-end repeated  message-start message-end &allow-other-keys)
  "Map Function which populates *PPPD-SESSIONS-TABLE*."
  (check-host-name host-name)
  (when (eq process-name (trie:gettrie "pppd" *process-name-trie*))
    (assert (numberp process-number))
    (let* ((x (pppd-session-get-create process-number)))
      (assert (not (find lineno (pppd-session-lines x))))
      (unless repeated
	(tagbody loop
	   (handler-bind ((start-new-session
			   (lambda (c)
			     (warn "~S: Creating new session for process ~D at line ~D:" c process-number lineno)
			     (setq x (pppd-session-get-create process-number t)) ;new session
			     (go loop))))
	     (pppd-session-set-slot-from-line x line date-start date-end message-start message-end))))
      (push lineno (pppd-session-lines x)))))

(defun pppd-all-sessions ()
  "Returns an array of PPPD-SESSIONS which were found in
*PPPD-SESSIONS-TABLE*.  Expects to find a count of *PPPD-SESSION-COUNTER*
objects."
  (let ((all-sessions (make-array *pppd-session-counter* :initial-element nil))
	(counted 0))
    (loop for key being each hash-key of *pppd-sessions-table*
	  using (hash-value pppd-sessions-list)
	  do (loop for x in pppd-sessions-list
		   for index = (pppd-session-index x)
		   do (unless (null (aref all-sessions index))
			(cerror "Continue Replacing it"
				"Session INDEX at ~D exists: ~S" index x))
		   (incf counted)
		   (setf (aref all-sessions index) x)))
    (unless (= counted *pppd-session-counter*)
      (cerror "Continue," "ALL-SESSIONS: *PPPD-SESSION-COUNTER* = ~D but found ~D sessions."
	      *PPPD-SESSION-COUNTER* counted))
    all-sessions))

#+NIL
(defmacro with-auto-replace-restart (&body body)
  "Evaluate BODY forms in an environment which invokes the REPLACE restart on
any error."
  `(handler-bind ((error (lambda (c)
			   (when (find-restart 'replace)
			     (warn "Auto-invoking REPLACE restart on ~S:
~S."
				   c (princ-to-string c))
			     (invoke-restart 'replace)))))
     ,@body))

(defun pppd-slice (sessions hitime lotime)
  "Return a subsequence of the list of pppd-sessions SESSIONS sorted in
descending order of PPPD-SESSION-CONNECTED times that lie between universal
times LOTIME and HITIME (inclusive)"
  (assert (>= hitime lotime))
  (loop with hicons and locons
	for lastx = nil then x
	for cons on sessions
	for x = (car cons) for i from 0 do
	(when lastx
	  #+nil ;allow sessions to be sorted later: ;madhu 080529
	  (assert (>= (pppd-session-index lastx) (pppd-session-index x)))
	  (assert (>= (utime (pppd-session-connected lastx))
		      (utime (pppd-session-connected x)))
		  nil  "i: ~D not sorted: lastp=~&~A p=~&~A" i lastx x))
	(unless hicons
	  (when (>= hitime (utime (pppd-session-connected x)))
	    (setq hicons cons)))
	(unless locons
	  (when (> lotime (utime (pppd-session-connected x)))
	    (setq locons cons)))
	finally (return (ldiff hicons locons))))

(defun collect-sessions-by-auth (sessions &rest keywords)
  (loop for x in sessions
	if (and (member (pppd-session-authentication x) keywords)
		(pppd-session-connection-terminated x))
	collect x))

(defun sum-xfers (sessions)
  (let ((sent 0) (recv 0))
    (values
     (reduce #'+ sessions
	     :key #'(lambda (x)
		      (+
		       (let ((n (pppd-session-sent-bytes x)))
			 (cond ((numberp n) (incf sent n) n)
			       (t (warn "SUM SENT-BYTES: Ignoring session ~A" x) 0)))
		       (let ((n (pppd-session-received-bytes x)))
			 (cond ((numberp n) (incf recv n) n)
			       (t (warn "SUM RECV-BYTES: Ignoring session ~A" x) 0))))))
     sent
     recv)))

#||
(pppd-initialize-session-creation 5)
(with-auto-replace-restart (syslog-map-lines "/var/log/daemon.log" #'pppd1))
(defvar $all-sessions (pppd-all-sessions))
(length $all-sessions)
(defvar $unconnected nil)
(defvar $connected nil)
(loop for x across $all-sessions
      if (pppd-session-connected x) do (push x $connected)
      else do (push x $unconnected))
(+ (length $connected) (length $unconnected))
(loop for lastx = nil then x
      for x in $connected for i from 0
      when lastx do
      (assert (>= (pppd-session-index lastx) (pppd-session-index x)))
      (assert (>= (utime (pppd-session-connected lastx))
		  (utime (pppd-session-connected x)))
	      nil  "i: ~D lastp=~&~A p=~&~A" i lastx x))
(defvar $hi (get-universal-time))
(defvar $lo (encode-universal-time 0 0 0 1 7 2007 -11/2))
(defvar $chap (loop for x in (pppd-slice $connected $hi $lo)
		    if (and (eq (pppd-session-authentication x) :chap)
			    (pppd-session-connection-terminated x))
		    collect x))
(reduce #'+ $chap :key #'(lambda (x)
			   (+ (pppd-session-received-bytes x)
			      (pppd-session-sent-bytes x))))
||#