;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-

;; http://common-lisp.net/project/postmodern/
(defparameter *xmlns* "urn:ietf:params:xml:ns:xfb-0.1")
(defparameter *version* 0.1)

;; XML attributes, all required:
;; (xmlns :col-type string :initform *xmlns*)
;; (version :col-type string :initform *version*)
;; (length :col-type string :initarg length)

; (require 'postmodern)
; (use-package 'postmodern)
(defclass bgp-message ()
  ((id :col-type serial)
   (timestamp :col-type integer :accessor timestamp :initform 0)
   (precision-time :col-type (or db-null smallint) :accessor precision-time :initform 0)
   (prefix :col-type cidr :accessor prefix :initarg :prefix)
   (label :col-type string ;FIXME: smallint or enum
	  :accessor label :initarg :label
	  :documentation "1-NANN, 2-WITH, 3-DANN, 4-DUPW, 5-DPATH, 6-SPATH")
   (path :col-type (or db-null integer[]) :accessor path :initform "{}")
   (nexthop :col-type (or db-null inet) :accessor nexthop :initform "0.0.0.0")
   (bgp-octets :col-type string :accessor bgp-octets)) ; FIXME: binary to save space.
  (:metaclass dao-class)
  (:keys id))

;; Database.
;; Create table by evaluating
;;   (connect-toplevel "linus" "linus" "" "localhost")
;;   (execute (dao-table-definition 'bgp-message))

;; XML.
;; node elements have dom:tag-name
;; text elements have dom:data

(defun prefix-pair (node)
  )

(defun new-bgp-message (templ pref)
  (let ((msg (make-instance 'bgp-message
			    :prefix (car pref)
			    :label (cadr pref))))
    ;; FIXME: Use accessor functions.
    ;; FIXME2: Move this to a method of the class.
    (setf (slot-value msg 'timestamp) (slot-value templ 'timestamp)
	  (slot-value msg 'precision-time) (slot-value templ 'precision-time)
	  (slot-value msg 'path) (slot-value templ 'path)
 	  (slot-value msg 'nexthop) (slot-value templ 'nexthop)
 	  (slot-value msg 'bgp-octets) (slot-value templ 'bgp-octets))
    msg))
  
(defun xml-top-elem-from-octets (xml-octets)
  (dom:document-element
   (cxml:parse xml-octets (cxml-dom:make-dom-builder))))

(defun new-entries (top-elem)
  "Return BGP-MESSAGE's, one per prefix mentioned in TOP-ELEM.
TOP-ELEM is an XML document element."
  ;; We assume that top-elem is "BGP_MESSAGE".
  ;(print (describe top-elem))
  (let ((updates (dom:get-elements-by-tag-name top-elem "UPDATE"))
	(new-elements nil))
    (when (> (length updates) 0)
      (let ((update (aref updates 0)))
	(when (string= (dom:tag-name (dom:parent-node update)) "ASCII_MSG")
	  (let ((templ (make-instance 'bgp-message))
		(new-prefs nil)
		(octet-msgs (dom:get-elements-by-tag-name top-elem "OCTET_MSG"))
		(prefixes (dom:get-elements-by-tag-name top-elem "PREFIX"))
		(time (aref (dom:get-elements-by-tag-name top-elem "TIME") 0)))

	    ;; Populate new-prefs.
	    (when (> (length prefixes) 0)
	      (setf new-prefs
		    (concatenate
		     'list
		     new-elements
		     (map 'list
			  (lambda (p)
			    (list (dom:data (aref (dom:child-nodes p) 0))
				  (dom:get-attribute p "label")))
			  prefixes))))

	    ;; Populate the template.
	    (let ((ts (aref (dom:get-elements-by-tag-name time "TIMESTAMP") 0))
		  (pt (aref (dom:get-elements-by-tag-name time "PRECISION_TIME") 0)))
	      (setf (timestamp templ)
		    (dom:data (aref (dom:child-nodes ts) 0)))
	      (setf (precision-time templ)
		    (dom:data (aref (dom:child-nodes pt) 0))))

	    ;; Add octets to templ.
	    (when (> (length octet-msgs) 0)
	      (let* ((oct (aref (dom:get-elements-by-tag-name
				 (aref octet-msgs 0) "OCTETS")
				0))
		     (txt (aref (dom:child-nodes oct) 0)))
		(setf (bgp-octets templ) (dom:data txt))))

	    ;; Create new elements from new-prefs and the template.
	    ;(format t "templ: ~A~%" (describe templ))
	    ;(format t "new-prefs: ~A~%" new-prefs)
	    (dolist (p new-prefs)
	      (push (new-bgp-message templ p) new-elements))))))
    new-elements))

(defun new-entry-klacks (xml-doc)
  "Return a fresh BGP-MESSAGE built from XML-DOC (array of unsigned bytes)."
  (let ((s (cxml:make-source xml-doc))
	(e (make-instance 'bgp-message))
	(cur-name nil))
    (do ((key (klacks:peek s) (klacks:peek s)))
	((null key) e)
      (case key
	(:start-element (setf cur-name (klacks:current-qname s)))
	(:end-element (setf cur-name nil))
	(:characters (let ((txt (klacks:current-characters s)))
		       (unless (or (string= cur-name "OCTET_MSG"))
			 (setf (slot-value e (intern cur-name)) txt)))))
      (klacks:consume s))))