diff options
Diffstat (limited to 'clog.lisp')
-rw-r--r-- | clog.lisp | 228 |
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)) |