Revision: 3702 Author: hans URL: http://bknr.net/trac/changeset/3702

Add streaming JSON encoding infrastructure and handler for news.

U trunk/bknr/web/src/rss/rss.lisp U trunk/projects/quickhoney/src/handlers.lisp

Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-30 21:06:43 UTC (rev 3701) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-31 06:18:02 UTC (rev 3702) @@ -117,6 +117,12 @@ (when days-string (parse-integer days-string)))))

+(defun month-from-query-parameter () + (when (boundp 'hunchentoot:*request*) + (let ((month-string (bknr.web:query-param "month"))) + (when month-string + (mapcar #'parse-integer (cl-ppcre:split "([-/]|(?<=..))" month-string :limit 2)))))) + (defun rss-channel-archive (channel) "Return the channel archive consisting of lists of lists ((MONTH YEAR) ITEM...)" (group-on (rss-channel-items channel) @@ -129,18 +135,21 @@

(defgeneric rss-channel-items (channel &key) (:documentation "Return all non-expired items in channel.") - (:method ((channel rss-channel) &key days month) - (cond - (month - (cdr (find month (rss-channel-archive channel) :test #'equal))) - (t - (let* ((days (or days - (days-from-query-parameter) - (rss-channel-max-item-age channel))) - (expiry-time (- (get-universal-time) (* 60 60 25 days)))) - (remove-if (lambda (item) (or (object-destroyed-p item) - (< (rss-item-pub-date item) expiry-time))) - (slot-value channel 'items))))))) + (:method ((channel rss-channel) &key days month count) + (unless month + (setf month (month-from-query-parameter))) + (unless days + (setf days (or (days-from-query-parameter) + (rss-channel-max-item-age channel)))) + (let ((items (if month + (cdr (find month (rss-channel-archive channel) :test #'equal)) + (let ((expiry-time (- (get-universal-time) (* 60 60 24 days)))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items)))))) + (if count + (subseq items 0 (min count (length items))) + items))))

(defgeneric rss-channel-archived-months (channel) (:documentation "Return a list of lists (MONTH YEAR) for which the

Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-07-30 21:06:43 UTC (rev 3701) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 06:18:02 UTC (rev 3702) @@ -432,49 +432,61 @@

(defvar *json-output*)

+(defclass json-output-stream () + ((stream :reader stream + :initarg :stream) + (stack :accessor stack + :initform nil))) + +(defun next-aggregate-element () + (if (car (stack *json-output*)) + (princ #, (stream *json-output*)) + (setf (car (stack *json-output*)) t))) + (defmacro with-json-output ((stream) &body body) - `(let ((*json-output* ,stream)) + `(let ((*json-output* (make-instance 'json-output-stream :stream ,stream))) ,@body))

(defmacro with-json-output-to-string (() &body body) - `(with-output-to-string (*json-output*) - ,@body)) + `(with-output-to-string (s) + (with-json-output (s) + ,@body)))

+(defmacro with-json-aggregate ((begin-char end-char) &body body) + `(progn + (when (stack *json-output*) + (next-aggregate-element)) + (princ ,begin-char (stream *json-output*)) + (push nil (stack *json-output*)) + (prog1 + (progn ,@body) + (pop (stack *json-output*)) + (princ ,end-char (stream *json-output*))))) + (defmacro with-json-array (() &body body) - (with-gensyms (need-comma) - `(let (,need-comma) - (princ #[ *json-output*) - (prog1 - (labels ((encode-array-element (value) - (if ,need-comma - (princ #, *json-output*) - (setf ,need-comma t)) - (json:encode-json value *json-output*))) - ,@body) - (princ #] *json-output*))))) + `(with-json-aggregate (#[ #]) + ,@body))

(defmacro with-json-object (() &body body) - (with-gensyms (need-comma) - `(let (,need-comma) - (princ #{ *json-output*) - (prog1 - (labels ((encode-object-member (key value) - (when value - (if ,need-comma - (princ #, *json-output*) - (setf ,need-comma t)) - (json:encode-json key *json-output*) - (princ #, *json-output*) - (json:encode-json value *json-output*)))) - ,@body) - (princ #} *json-output*))))) + `(with-json-aggregate (#{ #}) + ,@body))

+(defun encode-array-element (object) + (next-aggregate-element) + (json:encode-json object (stream *json-output*))) + +(defun encode-object-element (key value) + (next-aggregate-element) + (json:encode-json key (stream *json-output*)) + (princ #: (stream *json-output*)) + (json:encode-json value (stream *json-output*))) + (defmethod handle-object ((handler news-json-handler) (channel rss-channel)) (with-http-response (:content-type "application/json") (with-json-output-to-string () (with-json-array () (dolist (item (rss-channel-items channel)) (with-json-object () - (encode-object-member "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) - (encode-object-member "title" (rss-item-title item)) - (encode-object-member "description" (rss-item-description item)))))))) \ No newline at end of file + (encode-object-element "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) + (encode-object-element "title" (rss-item-title item)) + (encode-object-element "description" (rss-item-description item))))))))