Add the journal archive.

2 files changed, 79 insertions, 25 deletions

diff --git a/mulkcms-hunchentoot.lisp b/mulkcms-hunchentoot.lisp
index 205534f..664658d 100644
--- a/mulkcms-hunchentoot.lisp
+++ b/mulkcms-hunchentoot.lisp
@@ -13,13 +13,14 @@
 
 (defun dispatch-mulkcms-request (request)
   (let* ((relative-path (subseq (script-name request) 1)))
-    (mulkcms::find-mulkcms-request-handler relative-path)))
+    (or (mulkcms::find-journal-archive-request-handler relative-path)
+        (mulkcms::find-article-request-handler relative-path))))
 
 (defun setup-handlers ()
   (setq *dispatch-table*
-        (list* 'dispatch-static-file-request
-               (create-prefix-dispatcher "/admin" 'handle-admin-request)
+        (list* (create-prefix-dispatcher "/admin" 'handle-admin-request)
                'dispatch-mulkcms-request
+               'dispatch-static-file-request
                *dispatch-table*))
   (setq *default-handler* 'handle-mulkcms-request))
 
diff --git a/mulkcms.lisp b/mulkcms.lisp
index 60475ec..638026e 100644
--- a/mulkcms.lisp
+++ b/mulkcms.lisp
@@ -117,7 +117,78 @@
           :edit-button-label "Edit"
           :generic-commenter-name "Someone")))
 
-(defun find-mulkcms-request-handler (path &optional action characteristics)
+(defprepared find-journal-articles
+  "SELECT article
+     FROM article_revisions
+    WHERE status IN ('published', 'syndicated')
+    GROUP BY article
+   HAVING EXISTS (SELECT 1 FROM article_aliases
+                   WHERE article = article_revisions.article
+                     AND alias LIKE 'journal/%')
+    ORDER BY min(date) DESC"
+  :column)
+
+(defun find-journal-archive-request-handler (path &optional action characteristics)
+  (declare (ignore action))
+  (when (string= path "journal")
+    (lambda ()
+      (with-db
+        (let* ((articles (find-journal-articles))
+               ;; XXX This is probably horriby inefficient.  We may want
+               ;; to try to get FIND-ARTICLE-REVISIONS into the
+               ;; database as a view or at least a stored procedure.
+               (revisions (remove-if #'null
+                                     (mapcar (lambda (x)
+                                               (find-article-params x characteristics))
+                                             articles)))
+               (displayed-revisions (subseq revisions 0 10))
+               (page-skeleton (template "page_skeleton"))
+               (page-template (template "journal_page"))
+               (template-params (list :title *site-name*
+                                      :root *base-uri*
+                                      :site-name *site-name*
+                                      :site-subtitle ""
+                                      :link ""))
+               (head (expand-template page-template (list* :head t
+                                                           :articles displayed-revisions
+                                                           template-params)))
+               (body (expand-template page-template (list* :body t
+                                                           :articles displayed-revisions
+                                                           template-params))))
+          (expand-template page-skeleton (list :title *site-name*
+                                               :head head
+                                               :body body)))))))
+
+(defun find-article-params (article characteristics &optional commentary-p)
+  (let* ((revisions (find-article-revisions article characteristics))
+         (comment-data (if commentary-p
+                           (query "SELECT id FROM comments WHERE article = $1"
+                                  article
+                                  :column)
+                           (list)))
+         (comment-revision-data
+          (remove-if #'null
+                     (mapcar (lambda (cid)
+                               (first
+                                (query "SELECT *
+                                          FROM comment_revisions 
+                                         WHERE comment = $1
+                                           AND status IN ('approved', 'trusted')
+                                         ORDER BY date DESC"
+                                       cid
+                                       :lists)))
+                             comment-data)))
+         (comments (mapcar #'paramify-comment comment-revision-data))
+         (revision-data (first revisions)))
+    (cond ((null revision-data)
+           nil)
+          (commentary-p
+           (paramify-article revision-data comments))
+          (t
+           (paramify-article revision-data)))))
+
+
+(defun find-article-request-handler (path &optional action characteristics)
   (with-db
     (when-let ((article (query "SELECT article FROM article_aliases
                                  WHERE alias = $1"
@@ -131,38 +202,20 @@
                                               WHERE articles.id = $1"
                                             article
                                             :single!))
-                 (revisions (find-article-revisions article characteristics))
-                 (comment-data (query "SELECT id FROM comments WHERE article = $1"
-                                      article
-                                      :column))
-                 (comment-revision-data
-                  (remove-if #'null
-                             (mapcar (lambda (cid)
-                                       (first
-                                        (query "SELECT *
-                                                  FROM comment_revisions 
-                                                 WHERE comment = $1
-                                                   AND status IN ('approved', 'trusted')
-                                                 ORDER BY date DESC"
-                                               cid
-                                               :lists)))
-                                     comment-data)))
-                 (comments (mapcar #'paramify-comment comment-revision-data))
-                 (revision-data (first revisions))
+                 (article-params (find-article-params article characteristics))
                  (page-skeleton (template "page_skeleton"))
                  (page-template (template page-template-name))
-                 (template-params (list :title (fourth revision-data)
+                 (template-params (list :title (getf article-params :title)
                                         :root *base-uri*
                                         :site-name *site-name*
                                         :site-subtitle ""
                                         :link ""))
-                 (article-params (paramify-article revision-data comments))
                  (head (expand-template page-template (list* :head t
                                                              :articles (list article-params)
                                                              template-params)))
                  (body (expand-template page-template (list* :body t
                                                              :articles (list article-params)
                                                              template-params))))
-            (expand-template page-skeleton (list :title (fourth revision-data)
+            (expand-template page-skeleton (list :title (getf article-params :title)
                                                  :head head
                                                  :body body))))))))