diff options
| -rw-r--r-- | journal-content.lisp | 84 | ||||
| -rw-r--r-- | main.lisp | 33 | ||||
| -rw-r--r-- | utils.lisp | 21 |
3 files changed, 137 insertions, 1 deletions
diff --git a/journal-content.lisp b/journal-content.lisp index 65ac245..cf31ae6 100644 --- a/journal-content.lisp +++ b/journal-content.lisp @@ -68,7 +68,15 @@ :db-info (:join-class journal-comment :home-key id :foreign-key entry-id - :set t)))) + :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 () @@ -127,6 +135,61 @@ :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 :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-category () ((id :db-kind :key @@ -152,6 +215,8 @@ ;; (@* "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) @@ -182,6 +247,13 @@ (setf (%comments-about journal-entry) new-value)) +(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 @@ -202,6 +274,16 @@ #.(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 @@ -50,6 +50,7 @@ ((string= "comment-feed" (first *subpath*)) :view-comment-feed) ((string= "debug" (first *subpath*)) :view-debugging-page) ((string= "preview" (car (last *subpath*))) :preview-entry) + ((string= "trackback" (car (last *subpath*))) :post-trackback) ((string= "save" (car (last *subpath*))) :save-entry) (*post-number* :view) (t nil)))) @@ -187,6 +188,38 @@ (when (eq *site* :nfs.net) (mail-comment *notification-email* comment entry)))) (show-web-journal)) + (:post-trackback (with-transaction () + (let* ((entry (find-entry *post-number*)) + (trackback + (make-instance 'journal-trackback + :id (make-journal-trackback-id) + :uuid (make-uuid) + :entry-id (id-of entry) + :date (get-universal-time) + :blog-name (getf *query* :blog-name) + :title (getf *query* :title) + :excerpt (getf *query* :excerpt) + :url (getf *query* :url) + :submitter-ip (gethash "REMOTE_ADDR" *http-env*) + :submitter-user-agent (gethash "HTTP_USER_AGENT" *http-env*)))) + (http-send-headers "application/atom+xml; charset=UTF-8") + (cond + ((getf *query* :url) + (push trackback (trackbacks-about entry)) + (format t "<?xml version=\"1.0\" encoding=\"utf-8\"?>~&<response>~&<error>0</error>~&</response>")) + (t + (format t "<?xml version=\"1.0\" encoding=\"utf-8\"?>~&<response>~&<error>1</error>~&<message>No URI was provided.</message>~&</response>"))) + (with-slots (spam-p) trackback + (setq spam-p (detect-spam trackback + :referrer (gethash "HTTP_REFERER" *http-env*)))) + (update-records-from-instance trackback) + (update-records-from-instance entry) + (unless (spamp trackback) + (update-records 'journal_trackback + :where [= [slot-value 'journal-trackback 'id] (id-of trackback)] + :av-pairs `((spam_p nil)))) + (when (eq *site* :nfs.net) + (mail-trackback *notification-email* trackback entry))))) (:view-atom-feed (show-atom-feed)) (:view-comment-feed (show-comment-feed)) (:view-debugging-page (show-debugging-page)) @@ -328,6 +328,27 @@ ELEMENT-TYPE as the stream's." (spamp comment) (body-of comment)))) +(defun mail-trackback (address comment entry) + (mail address + (format nil "[Trackback] ~A" (title-of entry)) + (format nil "~&Trackback von: ~A~ + ~&Nummer: ~A~ + ~&Titel: ~A~ + ~&Web-Adresse: ~A~ + ~&IP-Adresse: ~A~ + ~&Webbrowser: ~A~ + ~&Als Spam erkannt: ~A~ + ~&~%~ + ~&~A" + (blog-name-of comment) + (id-of comment) + (title-of comment) + (url-of comment) + (submitter-ip comment) + (submitter-user-agent comment) + (spamp comment) + (excerpt-of comment)))) + (defun revalidate-cache-or-die (content-type) #+clisp (when *if-modified-since* |