[bknr-cvs] hans changed trunk/ - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

1 Aug 2008

Revision: 3713
Author: hans
URL: http://bknr.net/trac/changeset/3713
News start working.
U   trunk/bknr/web/src/rss/rss.lisp
U   trunk/projects/quickhoney/src/handlers.lisp
A   trunk/projects/quickhoney/src/json.lisp
U   trunk/projects/quickhoney/src/quickhoney.asd
U   trunk/projects/quickhoney/src/webserver.lisp
U   trunk/projects/quickhoney/website/static/javascript.js
U   trunk/projects/quickhoney/website/static/styles.css
U   trunk/projects/quickhoney/website/templates/index.xml
Modified: trunk/bknr/web/src/rss/rss.lisp
===================================================================

--- trunk/bknr/web/src/rss/rss.lisp	2008-07-31 16:31:28 UTC (rev 3712)
+++ trunk/bknr/web/src/rss/rss.lisp	2008-07-31 22:25:05 UTC (rev 3713)
@@ -121,35 +121,37 @@
   (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))))))
+        (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)
+  (group-on (rss-channel-items channel :all t)
             :test #'equal
             :key (lambda (item)
                    (multiple-value-bind (seconds minutes hours day month year)
                        (decode-universal-time (rss-item-pub-date item))
                      (declare (ignore seconds minutes hours day))
-                     (list month year)))))
+                     (list year month)))))
(defgeneric rss-channel-items (channel &key)
   (:documentation "Return all non-expired items in channel.")
-  (:method ((channel rss-channel) &key days month count)
+  (:method ((channel rss-channel) &key days month count all)
     (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))))
+    (if all
+        (remove-if #'object-destroyed-p (slot-value channel 'items))
+        (let ((items (if month
+                         (cdr (find month (rss-channel-archive channel) :test #'equal :key #'car))
+                         (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-31 16:31:28 UTC (rev 3712)
+++ trunk/projects/quickhoney/src/handlers.lisp	2008-07-31 22:25:05 UTC (rev 3713)
@@ -426,67 +426,46 @@
    	      (: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)
+(defclass rss-channel-handler (object-handler)
   ()
   (:default-initargs :object-class 'rss-channel :query-function #'find-rss-channel))
-(defvar *json-output*)
+(defclass json-news-handler (rss-channel-handler)
+  ())
-(defclass json-output-stream ()
-  ((output-stream :reader output-stream
-                  :initarg :output-stream)
-   (stack :accessor stack
-          :initform nil)))
-(defun next-aggregate-element ()
-  (if (car (stack *json-output*))
-      (princ #, (output-stream *json-output*))
-      (setf (car (stack *json-output*)) t)))
+(defgeneric json-encode-news-item (item)
+  (:method ((item t))
+    ; do nothing
+    )
+  (:method ((image quickhoney-image))
+    (let ((vectorp (member :vector (store-image-keywords image))))
+      (encode-object-element "uploader" (if vectorp "Peter" "Nana"))
+      (encode-object-element "category" (if vectorp "vector" "pixel"))
+      (encode-object-element "subcategory" "unknown")
+      (encode-object-element "date" (format-date-time (rss-item-pub-date image) :vms-style t :show-time nil))
+      (encode-object-element "name" (store-image-name image)))))
-(defmacro with-json-output ((stream) &body body)
-  `(let ((*json-output* (make-instance 'json-output-stream :output-stream ,stream)))
-     ,@body))
-
-(defmacro with-json-output-to-string (() &body 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 (output-stream *json-output*))
-     (push nil (stack *json-output*))
-     (prog1
-         (progn ,@body)
-       (pop (stack *json-output*))
-       (princ ,end-char (output-stream *json-output*)))))
-
-(defmacro with-json-array (() &body body)
-  `(with-json-aggregate (#[ #])
-     ,@body))
-
-(defmacro with-json-object (() &body body)
-  `(with-json-aggregate (#{ #})
-     ,@body))
-
-(defun encode-array-element (object)
-  (next-aggregate-element)
-  (json:encode-json object (output-stream *json-output*)))
-
-(defun encode-object-element (key value)
-  (next-aggregate-element)
-  (json:encode-json key (output-stream *json-output*))
-  (princ #: (output-stream *json-output*))
-  (json:encode-json value (output-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 ()
+(defmethod handle-object ((handler json-news-handler) (channel rss-channel))
+  (with-json-response ()
+    (with-object-element ("items")
       (with-json-array ()
         (dolist (item (rss-channel-items channel))
           (with-json-object ()
-            (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))))))))
+            (json-encode-news-item item)))))))
+
+(defclass json-news-archive-handler (rss-channel-handler)
+  ())
+
+(defmethod handle-object ((handler json-news-archive-handler) (channel rss-channel))
+  (with-json-response ()
+    (with-object-element ("months")
+      (with-json-array ()
+        (dolist (month (sort (rss-channel-archived-months channel)
+                              (lambda (a b)
+                                (if (= (first a) (first b))
+                                    (> (second a) (second b))
+                                    (> (first a) (first b))))))
+          (with-json-array ()
+            (encode-array-element (first month))
+            (encode-array-element (second month))))))))
\ No newline at end of file
Added: trunk/projects/quickhoney/src/json.lisp
===================================================================
--- trunk/projects/quickhoney/src/json.lisp	                        (rev 0)
+++ trunk/projects/quickhoney/src/json.lisp	2008-07-31 22:25:05 UTC (rev 3713)
@@ -0,0 +1,67 @@
+(in-package :quickhoney)
+
+(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 (car (stack *json-output*)) (stream *json-output*))
+      (setf (car (stack *json-output*)) #,)))
+
+(defmacro with-json-output ((stream) &body body)
+  `(let ((*json-output* (make-instance 'json-output-stream :stream ,stream)))
+     ,@body))
+
+(defmacro with-json-output-to-string (() &body 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-json-aggregate (#[ #])
+     ,@body))
+
+(defmacro with-json-object (() &body body)
+  `(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*)))
+
+(defmacro with-object-element ((key) &body body)
+  `(progn
+     (next-aggregate-element)
+     (json:encode-json ,key (stream *json-output*))
+     (setf (car (stack *json-output*)) #:)
+     (unwind-protect
+          (progn ,@body)
+       (setf (car (stack *json-output*)) #,))))
+
+(defmacro with-json-response (() &body body)
+  `(with-http-response (:content-type "application/json")
+    (with-json-output-to-string ()
+      (with-json-object ()
+        ,@body))))
Modified: trunk/projects/quickhoney/src/quickhoney.asd
===================================================================
--- trunk/projects/quickhoney/src/quickhoney.asd	2008-07-31 16:31:28 UTC (rev 3712)
+++ trunk/projects/quickhoney/src/quickhoney.asd	2008-07-31 22:25:05 UTC (rev 3713)
@@ -32,7 +32,8 @@
                (:file "news" :depends-on ("image"))
           (:file "layout" :depends-on ("config"))
           (:file "imageproc" :depends-on ("config"))
-	       (:file "handlers" :depends-on ("layout" "config" "image"))
+               (:file "json" :depends-on ("packages"))
+	       (:file "handlers" :depends-on ("json" "layout" "config" "image"))
           (:file "tags" :depends-on ("image"))
           (:file "webserver" :depends-on ("handlers"))
           (:file "daily" :depends-on ("config"))
Modified: trunk/projects/quickhoney/src/webserver.lisp
===================================================================
--- trunk/projects/quickhoney/src/webserver.lisp	2008-07-31 16:31:28 UTC (rev 3712)
+++ trunk/projects/quickhoney/src/webserver.lisp	2008-07-31 22:25:05 UTC (rev 3713)
@@ -33,7 +33,8 @@
    				("/admin" admin-handler)
                                         ("/upload-news" upload-news-handler)
                                         ("/digg-image" digg-image-handler)
-                                        ("/news-json" news-json-handler)
+                                        ("/json-news-archive" json-news-archive-handler)
+                                        ("/json-news" json-news-handler)
    				("/" template-handler
                                          :default-template "frontpage"
    				 :destination ,(namestring (merge-pathnames "templates/" *website-directory*))
Modified: trunk/projects/quickhoney/website/static/javascript.js
===================================================================
--- trunk/projects/quickhoney/website/static/javascript.js	2008-07-31 16:31:28 UTC (rev 3712)
+++ trunk/projects/quickhoney/website/static/javascript.js	2008-07-31 22:25:05 UTC (rev 3713)
@@ -215,11 +215,80 @@
/* news */
-function load_news()
+var month_names = [ 'January', 'February', 'March', 'April', 'May', 'June',
+                    'July', 'August', 'September', 'October', 'November', 'December' ];
+
+function select_archive_year()
 {
-    
+    var year = this.href.match(/#news/(\d+)/)[1];
+    map(function (element) {
+            if (element.href) {
+                ((element.href.match(/#news/(\d+)/)[1] == year) ? addElementClass : removeElementClass)(element, 'active');
+            }
+        }, this.parentNode.childNodes);
+    return true;
 }
+function select_archive_month()
+{
+    var month = this.href.match(/#news/(\d+/\d+)/)[1];
+    loadJSONDoc('/json-news/quickhoney?month=' + month).addCallbacks(load_news, alert);
+    return true;
+}
+
+function load_news(data)
+{
+    log('load news: ' + data.items.length);
+    replaceChildNodes('newsentries',
+                      map(function (item) {
+                              var color = (item.category == 'pixel') ? 'ff00ff' : '00ccff';
+                              return [ DIV({ 'class': 'newsentry autonews news_' + item.category },
+                                         IMG({ src: "/image/" + item.name + '/cutout-button,,' + color + ',98,4'}),
+                                         DIV(null,
+                                             H1(null, item.name),
+                                             item.date, ' by ', item.uploader, ' | ',
+                                             A({ href: '/index#' + item.category + '/' + item.subcategory + '/' + item.image_name }, 'permalink'),
+                                             BR(),
+                                             item.description)),
+                                       DIV({ 'class': 'news_sep' }) ];
+                          }, data.items));
+}
+
+function load_news_archive(data)
+{
+    try {
+        if (!data.months) {
+            alert('no archive data found');
+        }
+        var currentYear;
+        var active = true;
+        replaceChildNodes('archive-navigation',
+                          SPAN({ 'class': 'title' }, 'Archive'), BR(),
+                          map(function (entry) {
+                                  var year = entry[0];
+                                  var month = entry[1];
+                                  var result = [];
+                                  if (year != currentYear) {
+                                      if (currentYear) {
+                                          active = false;
+                                      }
+                                      currentYear = year;
+                                      var link = A({ href: '#news/' + year, 'class': 'year' }, year, BR());
+                                      link.onclick = select_archive_year;
+                                      result.push(link);
+                                  }
+                                  var link = A({ href: '#news/' + year + '/' + month, 'class': 'month ' + (active ? ' active' : '')},
+                                               month_names[month - 1], BR());
+                                  link.onclick = select_archive_month;
+                                  result.push(link);
+                                  return result;
+                              }, data.months));
+    }
+    catch (e) {
+        log('error while processing archive data: ' + e);
+    }
+}
+
 /* image database */
var current_directory;
@@ -391,7 +460,8 @@
           '30be01',
           function() {
    	   footer_hide();
-                   load_news();
+                   loadJSONDoc('/json-news-archive/quickhoney').addCallbacks(load_news_archive, alert);
+                   //                   load_news();
           });
pages['shop']
Modified: trunk/projects/quickhoney/website/static/styles.css
===================================================================
--- trunk/projects/quickhoney/website/static/styles.css	2008-07-31 16:31:28 UTC (rev 3712)
+++ trunk/projects/quickhoney/website/static/styles.css	2008-07-31 22:25:05 UTC (rev 3713)
@@ -627,4 +627,9 @@
    top: 0px;
    left: 585px;
         visibility: hidden;
-}
\ No newline at end of file
+}
+
+.archive span.title, .archive a.year { font-size: 1.5em; }
+.archive a.month.active { display: block; }
+.archive a.month { display: none; }
+.archive { padding-left: 1em; }
\ No newline at end of file
Modified: trunk/projects/quickhoney/website/templates/index.xml
===================================================================
--- trunk/projects/quickhoney/website/templates/index.xml	2008-07-31 16:31:28 UTC (rev 3712)
+++ trunk/projects/quickhoney/website/templates/index.xml	2008-07-31 22:25:05 UTC (rev 3713)
@@ -130,25 +130,33 @@
       </div>
<div id="news_page">
-        <p id="news_content">
-          <div class="newsentry news_vector autonews">
-            <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/>
-            <div>
-              <h1>Jan and Ella</h1>
-              March 8th, 2008 by Peter | <a href="foo">permalink</a><br/>
-              description
-            </div>
-          </div>
-          <div class="news_sep"> </div>
-          <br/>
-          <div class="newsentry news_pixel autonews">
-            <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/>
-            <div>
-              March 8th, 2008 by Peter | <a href="foo">permalink</a><br/>
-              description
-            </div>
-          </div>
-        </p>
+        <table border="0">
+          <tbody>
+            <tr>
+              <td valign="top" id="newsentries">
+                <div class="newsentry news_vector autonews">
+                  <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/>
+                  <div>
+                    <h1>Jan and Ella</h1>
+                    March 8th, 2008 by Peter | <a href="foo">permalink</a><br/>
+                    description
+                  </div>
+                </div>
+                <div class="news_sep"> </div>
+                <br/>
+                <div class="newsentry news_pixel autonews">
+                  <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/>
+                  <div>
+                    March 8th, 2008 by Peter | <a href="foo">permalink</a><br/>
+                    description
+                  </div>
+                </div>
+              </td>
+              <td class="archive" id="archive-navigation" valign="top">
+              </td>
+            </tr>
+          </tbody>
+        </table>
       </div>
<div id="cart_page">

    