[bknr-cvs] hans changed trunk/

[BKNR Commits]

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)))
      , at body))
 
 (defmacro with-json-output-to-string (() &body body)
-  `(with-output-to-string (*json-output*)
-     , at body))
+  `(with-output-to-string (s)
+     (with-json-output (s)
+       , at 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 , at 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*)))
-             , at body)
-         (princ #\] *json-output*)))))
+  `(with-json-aggregate (#\[ #\])
+     , at 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*))))
-             , at body)
-         (princ #\} *json-output*)))))
+  `(with-json-aggregate (#\{ #\})
+     , at 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))))))))