Support the posting of trackbacks.

Ignore-this: 5f2d53c3ba9415a9e66240e7b7711c4b

darcs-hash:6c085435bf95459afcb1ce53a55b058ef5b5a3d7

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
diff --git a/main.lisp b/main.lisp
index 9bc8d43..48c575d 100644
--- a/main.lisp
+++ b/main.lisp
@@ -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))
diff --git a/utils.lisp b/utils.lisp
index 877343e..4b09584 100644
--- a/utils.lisp
+++ b/utils.lisp
@@ -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*