From 55c3f987bd80ca38fa68c9eb08c1448a0329fee7 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Thu, 8 Oct 2009 11:24:55 +0200
Subject: Support the posting of trackbacks.

Ignore-this: 5f2d53c3ba9415a9e66240e7b7711c4b

darcs-hash:6c085435bf95459afcb1ce53a55b058ef5b5a3d7
---
 main.lisp | 33 +++++++++++++++++++++++++++++++++
 1 file changed, 33 insertions(+)

(limited to 'main.lisp')

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))
-- 
cgit v1.2.3