[bknr-cvs] hans changed trunk/projects/quickhoney/src/
BKNR Commits
bknr at bknr.net
Wed Jul 30 21:06:43 UTC 2008
Revision: 3701
Author: hans
URL: http://bknr.net/trac/changeset/3701
Work on JSON handler for news.
U trunk/projects/quickhoney/src/handlers.lisp
U trunk/projects/quickhoney/src/image.lisp
A trunk/projects/quickhoney/src/news.lisp
U trunk/projects/quickhoney/src/quickhoney.asd
U trunk/projects/quickhoney/src/webserver.lisp
Modified: trunk/projects/quickhoney/src/handlers.lisp
===================================================================
--- trunk/projects/quickhoney/src/handlers.lisp 2008-07-30 15:30:19 UTC (rev 3700)
+++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-30 21:06:43 UTC (rev 3701)
@@ -313,7 +313,8 @@
((:script :type "text/javascript" :language "JavaScript")
"function done() { window.opener.do_query(); window.close(); }"))
(:body
- (:p "Image " (:princ-safe (store-image-name image)) " with " (:princ-safe (hash-table-count color-table)) " colors uploaded")
+ (:p "Image " (:princ-safe (store-image-name image)) " with "
+ (:princ-safe (hash-table-count color-table)) " colors uploaded")
(:p ((:img :src (format nil "/image/~D" (store-object-id image))
:width (round (* ratio width)) :height (round (* ratio height)))))
(:p ((:a :href "javascript:done()") "ok")))))))))))
@@ -424,3 +425,56 @@
(:p "Error during upload:")
(:p (:princ-safe (apply #'format nil (simple-condition-format-control e) (simple-condition-format-arguments e))))
(:p ((:a :href "javascript:window.close()") "ok"))))))))))))
+
+(defclass news-json-handler (object-handler)
+ ()
+ (:default-initargs :object-class 'rss-channel :query-function #'find-rss-channel))
+
+(defvar *json-output*)
+
+(defmacro with-json-output ((stream) &body body)
+ `(let ((*json-output* ,stream))
+ , at body))
+
+(defmacro with-json-output-to-string (() &body body)
+ `(with-output-to-string (*json-output*)
+ , at body))
+
+(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*)))))
+
+(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*)))))
+
+(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
Modified: trunk/projects/quickhoney/src/image.lisp
===================================================================
--- trunk/projects/quickhoney/src/image.lisp 2008-07-30 15:30:19 UTC (rev 3700)
+++ trunk/projects/quickhoney/src/image.lisp 2008-07-30 21:06:43 UTC (rev 3701)
@@ -8,32 +8,6 @@
(spider-keywords :update :initform nil)
(products :update :initform nil)))
-(defmethod rss-item-pub-date ((item quickhoney-image))
- (blob-timestamp item))
-
-(defmethod quickhoney-image-explicit ((image quickhoney-image))
- (member :explicit (store-image-keywords image)))
-
-(defmethod rss-item-encoded-content ((image quickhoney-image))
- (let* ((category (first (intersection (store-image-keywords image) '(:vector :pixel))))
- (is-vector (eq category :vector)))
- (with-output-to-string (s)
- (html-stream
- s
- ((:div :class (format nil "newsentry news_~(~A~)" category))
- ((:img :src (format nil "http://~A/image/~A/cutout-button,,~A,98,4"
- (website-host)
- (store-object-id image)
- (if is-vector "00ccff" "ff00ff")))
- (:div
- (:h1 (:princ (store-image-name image)))
- (:princ (format nil "~A by ~A | "
- (format-date-time (blob-timestamp image))
- (if is-vector "Peter" "Nana")))
- ((:a :href (make-image-link image)) "permalink")))))
- (when (quickhoney-image-client image)
- (html-stream s :br "Client: " (:princ (quickhoney-image-client image)))))))
-
(defvar *last-image-upload-timestamp* 0)
(defmethod initialize-transient-instance :after ((image quickhoney-image))
@@ -48,21 +22,6 @@
(store-object-remove-keywords image 'bknr.web::keywords '(:import)))
(get-keywords-intersection-store-images '(:import))))
-(defmethod rss-item-channel ((item quickhoney-image))
- "quickhoney")
-
-(defmethod rss-item-title ((image quickhoney-image))
- (store-image-name image))
-
-(defmethod rss-item-description ((image quickhoney-image))
- (format nil "~A~@[ (Client: ~A)~]" (store-image-name image) (quickhoney-image-client image)))
-
-(defmethod rss-item-link ((image quickhoney-image))
- (make-image-link image))
-
-(defmethod rss-item-guid ((image quickhoney-image))
- (make-image-link image))
-
(defmethod quickhoney-image-category ((image quickhoney-image))
(first (intersection (store-image-keywords image) '(:pixel :vector :news :contact))))
@@ -81,27 +40,3 @@
(defmethod destroy-object :before ((image quickhoney-animation-image))
(delete-object (quickhoney-animation-image-animation image)))
-(define-persistent-class quickhoney-news-item (quickhoney-image)
- ((title :update)
- (text :update)))
-
-(defmethod quickhoney-image-spider-keywords ((item quickhoney-news-item))
- (quickhoney-news-item-title item))
-
-(defmethod rss-item-title ((item quickhoney-news-item))
- (quickhoney-news-item-title item))
-
-(defmethod rss-item-encoded-content ((item quickhoney-news-item))
- (concatenate 'string
- (call-next-method)
- (quickhoney-news-item-text item)))
-
-(defclass quickhoney-rss-channel (rss-channel)
- ()
- (:metaclass persistent-class))
-
-(defmethod rss-channel-items ((channel quickhoney-rss-channel) &key)
- (remove-if (lambda (item)
- (and (typep item 'quickhoney-image)
- (quickhoney-image-explicit item)))
- (call-next-method)))
\ No newline at end of file
Added: trunk/projects/quickhoney/src/news.lisp
===================================================================
--- trunk/projects/quickhoney/src/news.lisp (rev 0)
+++ trunk/projects/quickhoney/src/news.lisp 2008-07-30 21:06:43 UTC (rev 3701)
@@ -0,0 +1,68 @@
+(in-package :quickhoney)
+
+(defmethod rss-item-pub-date ((item quickhoney-image))
+ (blob-timestamp item))
+
+(defmethod quickhoney-image-explicit ((image quickhoney-image))
+ (member :explicit (store-image-keywords image)))
+
+(defmethod rss-item-encoded-content ((image quickhoney-image))
+ (let* ((category (first (intersection (store-image-keywords image) '(:vector :pixel))))
+ (is-vector (eq category :vector)))
+ (with-output-to-string (s)
+ (html-stream
+ s
+ ((:div :class (format nil "newsentry news_~(~A~)" category))
+ ((:img :src (format nil "http://~A/image/~A/cutout-button,,~A,98,4"
+ (website-host)
+ (store-object-id image)
+ (if is-vector "00ccff" "ff00ff")))
+ (:div
+ (:h1 (:princ (store-image-name image)))
+ (:princ (format nil "~A by ~A | "
+ (format-date-time (blob-timestamp image))
+ (if is-vector "Peter" "Nana")))
+ ((:a :href (make-image-link image)) "permalink")))))
+ (when (quickhoney-image-client image)
+ (html-stream s :br "Client: " (:princ (quickhoney-image-client image)))))))
+
+(defmethod rss-item-channel ((item quickhoney-image))
+ "quickhoney")
+
+(defmethod rss-item-title ((image quickhoney-image))
+ (store-image-name image))
+
+(defmethod rss-item-description ((image quickhoney-image))
+ (format nil "~A~@[ (Client: ~A)~]" (store-image-name image) (quickhoney-image-client image)))
+
+(defmethod rss-item-link ((image quickhoney-image))
+ (make-image-link image))
+
+(defmethod rss-item-guid ((image quickhoney-image))
+ (make-image-link image))
+
+(define-persistent-class quickhoney-news-item (quickhoney-image)
+ ((title :update)
+ (text :update)))
+
+(defmethod quickhoney-image-spider-keywords ((item quickhoney-news-item))
+ (quickhoney-news-item-title item))
+
+(defmethod rss-item-title ((item quickhoney-news-item))
+ (quickhoney-news-item-title item))
+
+(defmethod rss-item-encoded-content ((item quickhoney-news-item))
+ (concatenate 'string
+ (call-next-method)
+ (quickhoney-news-item-text item)))
+
+(defclass quickhoney-rss-channel (rss-channel)
+ ()
+ (:metaclass persistent-class))
+
+(defmethod rss-channel-items ((channel quickhoney-rss-channel) &key)
+ (remove-if (lambda (item)
+ (and (typep item 'quickhoney-image)
+ (quickhoney-image-explicit item)))
+ (call-next-method)))
+
Modified: trunk/projects/quickhoney/src/quickhoney.asd
===================================================================
--- trunk/projects/quickhoney/src/quickhoney.asd 2008-07-30 15:30:19 UTC (rev 3700)
+++ trunk/projects/quickhoney/src/quickhoney.asd 2008-07-30 21:06:43 UTC (rev 3701)
@@ -29,6 +29,7 @@
:components ((:file "packages")
(:file "config" :depends-on ("packages"))
(:file "image" :depends-on ("config"))
+ (:file "news" :depends-on ("image"))
(:file "layout" :depends-on ("config"))
(:file "imageproc" :depends-on ("config"))
(:file "handlers" :depends-on ("layout" "config" "image"))
Modified: trunk/projects/quickhoney/src/webserver.lisp
===================================================================
--- trunk/projects/quickhoney/src/webserver.lisp 2008-07-30 15:30:19 UTC (rev 3700)
+++ trunk/projects/quickhoney/src/webserver.lisp 2008-07-30 21:06:43 UTC (rev 3701)
@@ -33,6 +33,7 @@
("/admin" admin-handler)
("/upload-news" upload-news-handler)
("/digg-image" digg-image-handler)
+ ("/news-json" news-json-handler)
("/" template-handler
:default-template "frontpage"
:destination ,(namestring (merge-pathnames "templates/" *website-directory*))
More information about the Bknr-cvs
mailing list