1 files changed, 228 insertions, 0 deletions
diff --git a/clog.lisp b/clog.lisp
new file mode 100644
index 0000000..2a5321b
--- /dev/null
+++ b/clog.lisp
@@ -0,0 +1,228 @@
+;; clog -- Supposedly simplistic blogging in Common Lisp
+;; Copyright (C) 2013  Tom Willemse
+
+;; clog is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; clog is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with clog.  If not, see <http://www.gnu.org/licenses/>.
+
+(in-package :clog)
+
+(defclass clog (<app>) ())
+
+(defvar *app* (make-instance 'clog))
+
+(defmethod call ((this clog) env)
+  (prepare-tables)
+  (call-next-method))
+
+(defun make-tpl-parameters (&rest args)
+  (append (list :prefix (script-name *request*)) args))
+
+(defun post-tags (post)
+  (query (:select 'tag.* :from 'tag
+                  :inner-join 'post-tag
+                  :on (:and (:= 'id 'tag_id)
+                            (:= 'post_id (post-id post))))
+         (:dao tag)))
+
+(defun post-comments (post)
+  (query (:order-by
+          (:select :* :from 'post
+                   :where (:and (:= 'type "comment")
+                                (:= 'parent (post-id post))))
+          'timestamp)
+         (:dao post)))
+
+(defun tag-posts (tag)
+  (query (:order-by
+          (:select 'post.* :from 'post
+                   :inner-join 'post-tag
+                   :on (:and (:= 'id 'post_id)
+                             (:= 'tag_id (tag-id tag))))
+          'timestamp)
+         (:dao post)))
+
+(defun page-posts (page)
+  (query (:order-by
+          (:select :* :from 'post
+                   :where (:and (:= 'parent (post-id page))
+                                (:= 'type "blog")))
+          'timestamp)
+         (:dao post)))
+
+(defun comment-comments (comment)
+  (query (:order-by
+          (:select :* :from 'post
+                   :where (:and (:= 'parent (post-id comment))
+                                (:= 'type "comment")))
+          'timestamp)
+         (:dao post)))
+
+(defun timestamp->string (ts)
+  (multiple-value-bind (year month day hour minute second)
+      (decode-timestamp ts)
+    (format nil "~2,'0d-~2,'0d-~d ~2,'0d:~2,'0d:~2,'0d"
+            day month year hour minute second)))
+
+(defun post-params (post)
+  (list :title (post-title post)
+        :timestamp (timestamp->string (post-time post))
+        :slug (post-slug post)))
+
+(defun render-post (post &key (lvl 2) (content-render 'post-content))
+  (clog-templates:post
+   (append (post-params post)
+           (make-tpl-parameters
+            :content (funcall content-render post)
+            :tags (mapcar #'render-tag (post-tags post))
+            :lvl lvl
+            :type "posts"
+            :author (post-author-name post)))))
+
+(defun render-tag (tag)
+  (clog-templates:tag
+   (make-tpl-parameters :name (tag-name tag) :slug (tag-slug tag))))
+
+(defun render-page (page)
+  (clog-templates:post
+   (append (post-params page)
+           (make-tpl-parameters
+            :content (apply 'concatenate 'string (post-content page)
+                            (mapcar #'(lambda (post)
+                                        (render-post post :lvl 3))
+                                    (page-posts page)))
+            :tags (mapcar #'render-tag (post-tags page))
+            :lvl 2
+            :type "pages"))))
+
+(defun render-comment (comment)
+  (clog-templates:comment
+   (make-tpl-parameters
+    :comment (post-content comment)
+    :timestamp (timestamp->string (post-time comment))
+    :author (post-author-name comment)
+    :md5 (post-author-md5 comment)
+    :comments (mapcar #'render-comment
+                      (comment-comments comment)))))
+
+(defun get-posts (&key (type "blog") (parent-id :NULL))
+  (query (:order-by
+          (:select :* :from 'post
+                   :where (:and (:= 'type type)
+                                (:or (:and (:is-null parent-id)
+                                           (:is-null 'parent))
+                                     (:= 'parent parent-id))))
+          (:desc 'timestamp))
+         (:dao post)))
+
+(defun get-post (slug &key (type "blog"))
+  (query (:select :* :from 'post
+                  :where (:and (:= 'slug slug)
+                               (:= 'type type)))
+         (:dao post :single)))
+
+(defun get-tag (slug)
+  (query (:select :* :from 'tag :where (:= 'slug slug))
+         (:dao tag :single)))
+
+(defun post-list-page ()
+  (clog-templates:main
+   (make-tpl-parameters
+    :content (clog-templates:list
+              (make-tpl-parameters
+               :posts (mapcar #'render-post (get-posts)))))))
+
+(defun post-page (slug)
+  (let ((post (get-post slug)))
+    (list (if post 200 404)
+          '(:content-type "text/html")
+          (clog-templates:main
+           (make-tpl-parameters
+            :content (if post
+                         (clog-templates:single
+                          (make-tpl-parameters
+                           :post (render-post post)
+                           :comments (mapcar #'render-comment
+                                             (post-comments post))))
+                         "No such post"))))))
+
+(defun tag-page (slug)
+  (let ((tag (get-tag slug)))
+    (list (if tag 200 404)
+          '(:content-type "text/html")
+          (clog-templates:main
+           (make-tpl-parameters
+            :content
+            (if tag
+                (clog-templates:list
+                 (make-tpl-parameters
+                  :posts (mapcar #'render-post (tag-posts tag))))
+                "No such tag"))))))
+
+(defun page-page (slug)
+  (let ((page (get-post slug :type "page")))
+    (list (if page 200 404)
+          '(:content-type "text/html")
+          (clog-templates:main
+           (make-tpl-parameters
+            :content
+            (if page
+                (clog-templates:single
+                 (make-tpl-parameters
+                  :post (render-page page)
+                  :comments (mapcar #'render-comment
+                                    (post-comments page))))
+                "No such page"))))))
+
+(setf (route *app* "/") (lambda (params) (post-list-page)))
+(setf (route *app* "/posts/:slug")
+      (lambda (params) (post-page (getf params :slug))))
+(setf (route *app* "/tags/:slug")
+      (lambda (params) (tag-page (getf params :slug))))
+(setf (route *app* "/pages/:slug")
+      (lambda (params) (page-page (getf params :slug))))
+
+(setf (route *app* "/login" :method :POST)
+      #'(lambda (params)
+          (if (authorize (getf params :|username|)
+                         (getf params :|password|))
+              "Authorized!"
+              "Failed...Try again.")))
+
+(setf (route *app* "/hello/:name")
+      #'(lambda (params)
+          (format nil "Hello, ~A" (getf params :name))))
+
+(setf (route *app* "/say/*/to/*")
+      #'(lambda (params)
+          ;; matches /say/hello/to/world
+          (format nil "~S" (getf params :splat))))
+
+(setf (route *app* "/download/*.*")
+      #'(lambda (params)
+          ;; matches /download/path/to/file.xml
+          (format nil "~S" (getf params :splat))))
+
+(defun get-app ()
+  (clack.builder:builder
+   (<clack-middleware-static> :path "/static/" :root "static/")
+   (<clack-middleware-postmodern>
+    :database *dbname* :user *dbuser* :password *dbpass* :host *dbhost*)
+   clack.middleware.session:<clack-middleware-session>
+   *app*))
+
+;; (defparameter *urlmap* (make-instance '<clack-app-urlmap>))
+
+;; (mount *urlmap* "/clog/" (get-app))
+
+;; (defvar *handler*
+;;   (clackup *urlmap* :port 5004))