;;;; -*- coding: utf-8; mode: lisp -*- ;;;; Copyright 2007, Matthias Andreas Benkard. ;;;------------------------------------------------------------------------ ;;; This file is part of The Mulkblog Project. ;;; ;;; The Mulkblog Project is free software. You can redistribute it and/or ;;; modify it under the terms of the Affero General Public License as ;;; published by Affero, Inc.; either version 1 of the License, or ;;; (at your option) any later version. ;;; ;;; The Mulkblog Project 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 ;;; Affero General Public License for more details. ;;; ;;; You should have received a copy of the Affero General Public ;;; License in the COPYING file that comes with The Mulkblog Project; if ;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San ;;; Francisco, CA 94107 USA. ;;;------------------------------------------------------------------------ (in-package #:mulk.journal) ;;; (@* "Class definitions") (clsql:def-view-class journal-entry () ((id :db-kind :key :type integer :db-constraints :not-null :accessor id-of :initarg :id) (uuid :type (string 36) :db-constraints :not-null :accessor uuid-of :initarg :uuid) (title :type string :db-constraints :not-null :accessor title-of :initarg :title :initform "") (date :type universal-time :db-constraints :not-null :accessor date-of :initarg :date) (last-modification :type integer :accessor last-modification-of :initarg :last-modification :initform nil) (body :type string :db-constraints :not-null :accessor body-of :initarg :body :initform "") (type :type string :db-constraints :not-null :accessor entry-type-of :initarg :type :initform "markdown") (categories :db-kind :join :db-constraints :not-null :accessor categories-of :initarg :categories :initform '() :db-info (:join-class journal-category :home-key id :foreign-key entry-id :set t)) (comments :db-kind :join :db-constraints :not-null :accessor %comments-about :initarg :comments :db-info (:join-class journal-comment :home-key id :foreign-key entry-id :set t)) (trackbacks :db-kind :join :db-constraints :not-null :accessor %trackbacks-about :initarg :trackbacks :db-info (:join-class journal-trackback :home-key id :foreign-key entry-id :set t)))) (clsql:def-view-class journal-comment () ((id :db-kind :key :type integer :db-constraints :not-null :accessor id-of :initarg :id) (entry-id :type integer :db-constraints :not-null :accessor entry-id-of :initarg :entry-id) (entry :db-kind :join :db-constraints :not-null :accessor entry-of :initarg :entries :db-info (:join-class journal-entry :home-key entry-id :foreign-key id :set nil)) (uuid :type (string 36) :db-constraints :not-null :accessor uuid-of :initarg :uuid) (date :type universal-time :db-constraints :not-null :accessor date-of :initarg :date) (body :type string :db-constraints :not-null :accessor body-of :initarg :body :initform "") (author :type string :accessor author-of :initarg :author :initform nil) (email :type string :accessor email-of :initarg :email :initform nil) (website :type string :accessor website-of :initarg :website :initform nil) (spam-p :type boolean :accessor spamp :initarg :spamp :initform :spamp) (submitter-ip :type string :db-constraints :not-null :accessor submitter-ip :initarg :submitter-ip) (submitter-user-agent :type string :db-constraints :not-null :accessor submitter-user-agent :initarg :submitter-user-agent))) (clsql:def-view-class journal-trackback () ((id :db-kind :key :type integer :db-constraints :not-null :accessor id-of :initarg :id) (entry-id :type integer :db-constraints :not-null :accessor entry-id-of :initarg :entry-id) (entry :db-kind :join :db-constraints :not-null :accessor entry-of :initarg :entries :db-info (:join-class journal-entry :home-key entry-id :foreign-key id :set nil)) (uuid :type (string 36) :db-constraints :not-null :accessor uuid-of :initarg :uuid) (date :type universal-time :db-constraints :not-null :accessor date-of :initarg :date) (excerpt :type string :db-constraints :not-null :accessor excerpt-of :initarg :excerpt :initform "") (title :type string :accessor title-of :initarg :title :initform nil) (blog-name :type string :accessor blog-name-of :initarg :blog-name :initform nil) (url :type string :accessor url-of :initarg :url :initform nil) (spam-p :type boolean :accessor spamp :initarg :spamp :initform :spamp) (submitter-ip :type string :db-constraints :not-null :accessor submitter-ip :initarg :submitter-ip) (submitter-user-agent :type string :db-constraints :not-null :accessor submitter-user-agent :initarg :submitter-user-agent))) (clsql:def-view-class journal-category () ((id :db-kind :key :type integer :db-constraints :not-null :accessor id-of :initarg :id) (uuid :type (string 36) :db-constraints :not-null :accessor uuid-of :initarg :uuid) (entries :db-kind :join :db-constraints :not-null :accessor entries-in :initarg :entries :initform '() :db-info (:join-class journal-entry :home-key id :foreign-key catogory-ids :set t)))) ;; (@* "Journal entry operations") (defgeneric comments-about (thing &key ordered-p)) (defgeneric (setf comments-about) (new-value thing &key ordered-p)) (defgeneric trackbacks-about (thing &key ordered-p)) (defgeneric (setf trackbacks-about) (new-value thing &key ordered-p)) (defmethod comments-about ((journal-entry journal-entry) &key ordered-p ham-p) #.(locally-enable-sql-reader-syntax) (prog1 (if ordered-p (if ham-p (select 'journal-comment :where [and [= [slot-value 'journal-comment 'entry-id] (id-of journal-entry)] [= [slot-value 'journal-comment 'spam-p] "f"]] :order-by '([date]) :flatp t) (select 'journal-comment :where [= [slot-value 'journal-comment 'entry-id] (id-of journal-entry)] :order-by '([date]) :flatp t)) (if ham-p (comments-about journal-entry :ordered-p t :ham-p t) (%comments-about journal-entry))) #.(restore-sql-reader-syntax-state))) (defmethod (setf comments-about) (new-value (journal-entry journal-entry) &key ordered-p) (declare (ignore ordered-p)) (setf (%comments-about journal-entry) new-value)) (defmethod trackbacks-about ((journal-entry journal-entry) &key ordered-p ham-p) #.(locally-enable-sql-reader-syntax) (prog1 (if ordered-p (if ham-p (select 'journal-trackback :where [and [= [slot-value 'journal-trackback 'entry-id] (id-of journal-entry)] [= [slot-value 'journal-trackback 'spam-p] "f"]] :order-by '([date]) :flatp t) (select 'journal-trackback :where [= [slot-value 'journal-trackback 'entry-id] (id-of journal-entry)] :order-by '([date]) :flatp t)) (if ham-p (trackbacks-about journal-entry :ordered-p t :ham-p t) (%trackbacks-about journal-entry))) #.(restore-sql-reader-syntax-state))) (defmethod (setf trackbacks-about) (new-value (journal-entry journal-entry) &key ordered-p) (declare (ignore ordered-p)) (setf (%trackbacks-about journal-entry) new-value)) (defun make-journal-entry-id () #.(locally-enable-sql-reader-syntax) (prog1 (1+ (or (single-object (select [max [slot-value 'journal-entry 'id]] :from [journal-entry] :flatp t)) -1)) #.(restore-sql-reader-syntax-state))) (defun make-journal-comment-id () #.(locally-enable-sql-reader-syntax) (prog1 (1+ (or (single-object (select [max [slot-value 'journal-comment 'id]] :from [journal-comment] :flatp t)) -1)) #.(restore-sql-reader-syntax-state))) (defun make-journal-trackback-id () #.(locally-enable-sql-reader-syntax) (prog1 (1+ (or (single-object (select [max [slot-value 'journal-trackback 'id]] :from [journal-trackback] :flatp t)) -1)) #.(restore-sql-reader-syntax-state))) (defun find-entry (number) #.(locally-enable-sql-reader-syntax) (prog1 (single-object (select 'journal-entry :where [= [slot-value 'journal-entry 'id] number] :flatp t) nil) #.(restore-sql-reader-syntax-state))) (defun journal-markup->html (markup) (with-result-cache ((format nil "markup-~A" (sxhash markup)) :younger-than (compute-script-last-modified-date)) (if (string= "" markup) markup (handler-bind ((error ;; method-call-type-error or not ;; Work around a weird bug in cl-markdown or CLISP. (I ;; don't know which.) #'(lambda (c) (declare (ignore c)) #+nil (<:as-html (with-output-to-string (s) (system::pretty-print-condition c s))) (invoke-restart 'return nil)))) (fixup-markdown-output (with-output-to-string (s) ;; Normally, we shouldn't need to create our own stream to ;; write into, but this is, of course, yet another ;; CLISP/Markdown hack, because Markdown's default ;; *OUTPUT-STREAM* seems to spontaneously close itself, making ;; everything break when Markdown tries to render more stuff. (markdown (remove #\Return markup) ;
 treats CR, LF as two line breaks.  Ouch.
                       :stream s)))))))


(defun compute-journal-last-modified-date ()
  #.(locally-enable-sql-reader-syntax)
  (prog1
    #-clisp (get-universal-time)
    #+clisp
    (max (compute-script-last-modified-date)
         (or (single-object
              (select [max [slot-value 'journal-entry 'last-modification]]
                      :from [journal-entry]
                      :flatp t))
             0)
         (or (single-object
              (select [max [slot-value 'journal-entry 'date]]
                      :from [journal-entry]
                      :flatp t))
             0)
         (or (single-object
              (select [max [slot-value 'journal-comment 'date]]
                      :from [journal-comment]
                      :flatp t))
             0)
         (or (single-object
              (select [max [slot-value 'journal-trackback 'date]]
                      :from [journal-trackback]
                      :flatp t))
             0))
    #.(restore-sql-reader-syntax-state)))