clog/clog.lisp

;; 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))