;;;===========================================================================
;;;
;;; weblog.lisp
;;;
;;; Eduardo Muņoz
;;; Time-stamp: "Saturday, 25 December 2004 - 17:10:35"
;;;
;;;===========================================================================
;;;
;;; A lisp powered weblog.
;;; The following code is in the public domain.
;;;
;;;===========================================================================

(in-package :weblisp)

(use-package '(:htout))

(clsql:locally-enable-sql-reader-syntax)

(defparameter *blog-address* "/lisp/weblog")

(defvar *blog-db* (clsql:connect '(nil "blog" "emf" nil)
                                 :database-type :postgresql
                                 :if-exists :old))

(clsql:def-view-class post ()
  ((id
    :accessor post-id
    :type integer
    :db-kind :key
    :db-type "SERIAL")
   (valid
    :accessor post-valid
    :initarg :valid
    :initform t
    :type boolean)
   (author
    :accessor post-author
    :initarg :author
    :initform ""
    :type string)
   (email
    :accessor post-email
    :initarg :email
    :initform ""
    :type string)
   (title
    :accessor post-title
    :initarg :title
    :initform ""
    :type string)
   (body
    :accessor post-body
    :initarg :body
    :initform ""
    :type string
    :db-type "TEXT")
   (rating
    :accessor post-rating
    :initarg :rating
    :initform 0
    :type integer)
   (parent
    :accessor post-parent
    :initarg :parent
    :initform 0
    :type integer)
   (date
    :accessor post-date
    :initform "NOW"      
    :type string
    :db-type "TIMESTAMP (2)")
   (stid
    :accessor post-stid
    :initarg :stid
    :type integer)
   (story
    :accessor post-story
    :initarg :story
    :db-kind :join
    :db-info (:join-class story
                          :home-key stid
                          :foreign-key id
                          :set nil)))
  (:base-table blog)
  (:version 1))

(clsql:def-view-class story ()
  ((id
    :accessor story-id
    :type integer
    :db-kind :key
    :db-type "SERIAL")
   (valid
    :accessor story-valid
    :initarg :valid
    :initform t
    :type boolean)
   (title
    :accessor story-title
    :initarg :title
    :type string))
  (:base-table stories)
  (:version 1))

(clsql:def-view-class transaction ()
  ((id
    :accessor transaction-id
    :type integer
    :db-kind :key
    :db-type "SERIAL")
   (completed
    :accessor transaction-completed
    :type boolean
    :initform nil))
  (:base-table transactions)
  (:version 1))

(defun create-blog-tables ()
  (clsql:with-default-database (*blog-db*)
    (clsql:create-view-from-class 'post)
    (clsql:create-view-from-class 'story)
    (clsql:create-view-from-class 'transaction)))

(defun drop-blog-tables ()
  (clsql:with-default-database (*blog-db*)
    (clsql:drop-view-from-class 'post)
    (clsql:execute-command "drop sequence blog_id_seq;")
    (clsql:drop-view-from-class 'story)
    (clsql:execute-command "drop sequence stories_id_seq;")
    (clsql:drop-view-from-class 'transaction)
    (clsql:execute-command "drop sequence transactions_id_seq;")))

(with-apache-address (*blog-address* :public t)
  (standard-page "Weblog"
    (clsql:with-default-database (*blog-db*)
      (let* ((method (cdr (assoc "method" command :test #'string=)))
             (query (get-url-query command))
             (story-id (get-query-item "Story" query)))
        (when (stringp story-id)
          (setf story-id (parse-integer story-id)))
        (cond ((not query)
               (htm (:h1 "Weblog Index")
                    (str (view-index *blog-address*))))
              ((string= "Post" (get-query-item "Action" query))
               (htm (:h2 "Post a comment")
                    (str (edit-post (make-post :stid story-id)))
                    (:p (str (story-link story-id *blog-address*)))))
              ((string= "Reply" (get-query-item "Action" query))
               (let ((parent (select-post (parse-integer
                                           (get-query-item "Post" query)))))
                 (htm (str (view-post parent *blog-address*))
                      :hr
                      (:h2 "Post a reply")
                      (str (edit-post
                            (make-post
                             :stid story-id
                             :title (reply-title (post-title parent))
                             :parent (post-id parent))))
                      (:p (str (story-link story-id *blog-address*))))))
              (t
               (cond ((equal method "POST")
                      (htm (str (add-post (get-http-query command)))
                           (:p (str (story-link story-id *blog-address*)))))
                     (t
                      (htm (:h2 (str (story-title (select-story story-id))))
                           ((:a :name "0") "")
                           (str (view-blog (select-posts story-id)
                                           #'view-post *blog-address*
                                           :filter t))
                           (str (blog-footer story-id *blog-address*)))))))))))

(defun view-index (base-address)
  (html
   (:ul
    (dolist (st (select-stories))
      (htm
       (:li (:h3 (lnk (str (story-title st))
                      (format nil
                              "~A?Story=~D"
                              base-address
                              (story-id st))))))))))

(defun view-blog (posts view-fn base-address &key filter)
  (html
   (dolist (post posts)
     (when (or (post-valid post)
               (not filter))
       (htm
        (str (funcall view-fn post base-address))
        (let ((childs (select-childs post)))
          (when childs
            (htm
             (:dl (:dt)
                  (:dd (str (view-blog childs view-fn base-address
                                       :filter filter))))))))))))

(defun select-stories ()
  (clsql:select 'story
                ;; :from 'stories
                :where [= 'valid 'true]
                :order-by '(([id] :desc))
                :flatp t
                :limit 10))

(defun select-story (id)
  (car (clsql:select 'story
                   :flatp t
                   :where [= 'id id])))

(defun select-childs (post)
  (clsql:select 'post
                :flatp t
                :where [= 'parent (post-id post)]))
  
(defun view-post (post base-address)
  (let ((table-width "600"))
    (html
     ((:a :name (format nil "~D" (post-id post))) "")
     ((:table :bgcolor "#FFFFFF" :width table-width)
      ((:tr :bgcolor "#99CCEE")
       (:td
        ((:table :width table-width)
         (:tr (:td (:b (str (post-title post))))
              ((:td :align "right")
               (if (string/= "" (post-email post))
                   ;; (lnk (str (post-author post)) "mailto:" (post-email post))
                   (str (post-author post))
                   (str (post-author post)))))
         (:tr ((:td :align "left")
               ((:font :size "-1")
                (str (reply-link post base-address))))
              ((:td :align "right")
               ((:font :size "-1")
                (str (shorten-time-string (post-date post)))))))))
      ((:tr :bgcolor "#FFFFFF")
       (:td (str (post-body post)))))
     :br)))

(defun add-post (query)
  (let ((author (get-query-item "Author" query))
        (email (get-query-item "Email" query))
        (title (get-query-item "Title" query))
        (body (get-query-item "Body" query))
        (parent (parse-integer (get-query-item "Parent" query)))
        (story-id (parse-integer (get-query-item "Story" query)))
        (transaction (select-transaction
                      (parse-integer
                       (get-query-item "Transaction" query)))))
    (cond ((string= "" author)
           (html (:h2 "Sorry") (:p (:b "Author") " field is mandatory.")))
          ((transaction-completed transaction)
           (html (:h2 "Sorry") (:p "Article already posted.")))
          (t
           (clsql:with-transaction (:database *blog-db*)
             (let ((post (make-post :stid story-id
                                    :author author
                                    :email email
                                    :title title
                                    :body body
                                    :parent parent)))
               (clsql:update-records-from-instance post)
               ;; get assigned id
               (setf post (car (clsql:select 'post
                                             :flatp t
                                             :order-by '(([id] :desc))
                                             :limit 1)))
               (setf (transaction-completed transaction) t)
               (clsql:update-records-from-instance transaction)
               (view-post post *blog-address*)))))))

(defun edit-post (post)
  (html
   ((:form :name "Post" :method "POST"
           :action (format nil "/lisp/weblog?Story=~D"
                           (post-stid post)))
    ((:input :type "hidden" :name "Parent" :value (post-parent post)))
    ((:input :type "hidden" :name "Story"
             :value (post-stid post)))
    ((:input :type "hidden" :name "Transaction"
             :value (transaction-id (create-transaction))))
    (:table
     (:tr
      (:td (:b "Author: "))
      (:td ((:input :type "text" :name "Author"
                    :size "30" :value (post-author post)))))
     (:tr
      (:td (:b "Email: "))
      (:td ((:input :type "text" :name "Email"
                    :size "30" :value (post-email post)))))
     (:tr
      (:td (:b "Title: "))
      (:td ((:input :type "text" :name "Title"
                    :size "50" :value (post-title post)))))
     (:tr
      ((:td :valign "top") (:b "Body: "))
      (:td ((:textarea  :name "Body" :rows "10" :cols "38")
            (str (post-body post)))))
     (:tr (:td)
          (:td
           :br
           ((:input :type "submit" :name "Button" :value "Post"))))))))

(defun select-posts (story-id)
  (clsql:select 'post
                :order-by [id]
                :flatp t
                :where [and [= 'parent 0] [= 'stid story-id]]))

(defun select-post (post-id)
  (car (clsql:select 'post
                     :flatp t
                     :where [= 'id post-id])))

;; (defun make-post (story-id &rest args)
;;   (let ((post (apply #'make-instance (cons 'post args))))
;;     (clsql:add-to-relation post 'story (select-story story-id))
;;     post))

(defun make-post (&rest args)
  (let ((post (apply #'make-instance (cons 'post args))))
    ;; (clsql:add-to-relation post 'story (select-story story-id))
    post))

(defun create-transaction ()
  (let (id)
    (clsql:with-transaction (:database *blog-db*)
      (clsql:update-records-from-instance
       (make-instance 'transaction))
      (setf id (car (clsql:select 'transaction
                                  :flatp t
                                  :order-by '(([id] :desc))
                                  :limit 1))))
    id))

(defun select-transaction (id)
  (car (clsql:select 'transaction
                     :flatp t
                     :where [= 'id id])))

(defun blog-footer (story-id base-address)
  (html
   (:center
    ((:table :cellpadding "20")
     (:tr
      (:td (:h4 (lnk "Post a new comment"
                     (format nil
                             "~A?Story=~D&Action=Post"
                             base-address story-id))))
      (:td (:h4 (lnk "Weblog index" base-address))))))))

(defun story-link (story-id base-address)
  (html "Return to "
        (lnk (str (story-title (select-story story-id)))
             (format nil
                     "~A?Story=~D"
                     base-address
                     story-id))))

(defun reply-link (post base-address)
  (html (lnk "Reply to this"
             (format nil
                     "~A?Story=~D&Action=Reply&Post=~D"
                     base-address
                     (or (story-id (post-story post)) "99")
                     (post-id post)))))

(defun reply-title (title)
  (if (or (< (length title) 4)
          (not (string= "Re: " title :end2 4)))
      (format nil "Re: ~A" title)
      title))

(defun shorten-time-string (time)
  (subseq time 0 (position #\. time :from-end t)))


(defmethod print-object ((p post) (s stream))
  (print-unreadable-object (p s :type t)
    (with-slots (id author title date) p
      (format s "~A '~A' '~A' ~A" id author title date))))