[bknr-cvs] hans changed trunk/projects/quickhoney/src/tags.lisp

[BKNR Commits]

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

Hierarchical HTML browser.  This is far too inefficient yet.

U   trunk/projects/quickhoney/src/tags.lisp

Modified: trunk/projects/quickhoney/src/tags.lisp
===================================================================
--- trunk/projects/quickhoney/src/tags.lisp	2008-09-05 16:18:22 UTC (rev 3815)
+++ trunk/projects/quickhoney/src/tags.lisp	2008-09-05 16:25:53 UTC (rev 3816)
@@ -10,29 +10,64 @@
                                                     :vms-style t :show-time nil))))))
 
 (define-bknr-tag simple-image-browser ()
-  (let* ((image-name (parse-url))
-         (image (or (bknr.images:store-image-with-name image-name)
-                    (error #?"image $(image-name) not found"))))
-    (html
-     (:table
-      (:tbody
-       (:tr (:td "name") (:td (:princ image-name)))
-       (let ((next (cadr (member image (bknr.datastore:class-instances 'quickhoney-image)))))
-         (when next
-           (html (:tr (:td "next")
-                      (:td ((:a :href #?"/image-browse/$((bknr.images:store-image-name next))")
-                            (:princ (bknr.images:store-image-name next))))))))
-       (:tr (:td "width") (:td (:princ (bknr.images:store-image-width image))))
-       (:tr (:td "height") (:td (:princ (bknr.images:store-image-height image))))
-       (when (quickhoney-image-client image)
-         (html (:tr (:td "client") (:td (:princ (quickhoney-image-client image))))))
-       (when (quickhoney-image-spider-keywords image)
-         (html (:tr (:td "description") (:td (:princ (quickhoney-image-spider-keywords image))))))))
-     ((:img :src #?"/image/$(image-name)"
-            :width (bknr.images:store-image-width image)
-            :height (bknr.images:store-image-height image)))
-     ((:script :type "text/javascript")
-      (:princ #?"document.location.href = document.location.href.replace(/\\/image-browse.*/, '$((make-image-link image :internal t))');")))))
+  (tbnl:handle-if-modified-since (last-image-upload-timestamp))
+  (destructuring-bind (&optional category subcategory image-name) (multiple-value-list (parse-url))
+    (cond
+      (image-name
+       (let ((image (or (bknr.images:store-image-with-name image-name)
+                        (error #?"image $(image-name) not found"))))
+         (html
+          (:table
+           (:tbody
+            (:tr (:td "name") (:td (:princ image-name)))
+            (let ((next (cadr (member image (bknr.datastore:class-instances 'quickhoney-image)))))
+              (when next
+                (html (:tr (:td "next")
+                           (:td ((:a :href #?"/image-browse/$((bknr.images:store-image-name next))")
+                                 (:princ (bknr.images:store-image-name next))))))))
+            (:tr (:td "width") (:td (:princ (bknr.images:store-image-width image))))
+            (:tr (:td "height") (:td (:princ (bknr.images:store-image-height image))))
+            (when (quickhoney-image-client image)
+              (html (:tr (:td "client") (:td (:princ (quickhoney-image-client image))))))
+            (when (quickhoney-image-spider-keywords image)
+              (html (:tr (:td "description") (:td (:princ (quickhoney-image-spider-keywords image))))))))
+          ((:img :src #?"/image/$(image-name)"
+                 :width (bknr.images:store-image-width image)
+                 :height (bknr.images:store-image-height image)))
+          ((:script :type "text/javascript")
+           (:princ #?"document.location.href = document.location.href.replace(/\\/image-browse.*/, '$((make-image-link image :internal t))');")))))
+      (subcategory
+       (html
+        (:h1 (:princ #?"Images with category $(category) and subcategory $(subcategory)"))
+        (:ul
+         (dolist (image (bknr.images:get-keywords-intersection-store-images
+                         (mapcar #'make-keyword-from-string (list category subcategory))))
+           (html
+            (:li ((:a :href #?"/image-browse/$(category)/$(subcategory)/$((bknr.images:store-image-name image))")
+                  (:princ (bknr.images:store-image-name image)))))))))
+      (category
+       (html
+        (:h1 (:princ #?"Subcategories of $(category)"))
+        (:ul
+         (dolist (subcategory (mapcar #'car
+                                      (group-on (remove (find-class 'quickhoney::quickhoney-image)
+                                                        (bknr.images:get-keyword-store-images (make-keyword-from-string category))
+                                                        :test (complement #'eq) :key #'class-of)
+                                                :key #'quickhoney::quickhoney-image-subcategory)))
+           (html
+            (:li ((:a :href (format nil "/image-browse/~A/~(~A~)" category subcategory)))
+                 (:princ subcategory)))))))
+      (t
+       (html
+        (:h1 (:princ #?"Categories"))
+        (:ul
+         (dolist (category (mapcar #'car
+                                   (group-on (bknr.datastore:class-instances 'quickhoney::quickhoney-image)
+                                             :key #'quickhoney::quickhoney-image-category)))
+           (when category
+             (html
+              (:li ((:a :href (format nil "/image-browse/~(~A~)" category)))
+                   (:princ category)))))))))))
 
 (define-bknr-tag first-image-link ()
   (html
@@ -47,4 +82,5 @@
           (query-param "__username"))
      (html (:h1 "Login failed, please try again")))
     (t
-     (html (:h1 "Please login")))))
\ No newline at end of file
+     (html (:h1 "Please login")))))
+