Support pingbacks.

Ignore-this: 534fc0ed2f9e22c9b6a92cde14bedf2f

darcs-hash:d70c51f9d5d9002dab339dd6ceb79fef2cd89f27

5 files changed, 172 insertions, 4 deletions

diff --git a/journal-content.lisp b/journal-content.lisp
index 29f01e4..bf7458a 100644
--- a/journal-content.lisp
+++ b/journal-content.lisp
@@ -196,6 +196,51 @@
                          :accessor submitter-user-agent
                          :initarg :submitter-user-agent)))
 
+
+(clsql:def-view-class journal-pingback ()
+  ((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)
+   (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
@@ -222,6 +267,8 @@
 (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))
+(defgeneric pingbacks-about (thing &key ordered-p))
+(defgeneric (setf pingbacks-about) (new-value thing &key ordered-p))
 
 (defmethod comments-about ((journal-entry journal-entry) &key ordered-p ham-p)
   #.(locally-enable-sql-reader-syntax)
@@ -279,6 +326,34 @@
   (setf (%trackbacks-about journal-entry) new-value))
 
 
+(defmethod pingbacks-about ((journal-entry journal-entry) &key ordered-p ham-p)
+  #.(locally-enable-sql-reader-syntax)
+  (prog1 (if ordered-p
+             (if ham-p
+                 (select 'journal-pingback
+                         :where [and [= [slot-value 'journal-pingback 'entry-id]
+                                        (id-of journal-entry)]
+                                     [= [slot-value 'journal-pingback 'spam-p]
+                                        "f"]]
+                         :order-by '([date])
+                         :flatp t)
+                 (select 'journal-pingback
+                         :where [= [slot-value 'journal-pingback 'entry-id]
+                                   (id-of journal-entry)]
+                         :order-by '([date])
+                         :flatp t))
+             (if ham-p
+                 (pingbacks-about journal-entry :ordered-p t :ham-p t)
+                 (%pingbacks-about journal-entry)))
+    #.(restore-sql-reader-syntax-state)))
+
+(defmethod (setf pingbacks-about) (new-value
+                                    (journal-entry journal-entry)
+                                    &key ordered-p)
+  (declare (ignore ordered-p))
+  (setf (%pingbacks-about journal-entry) new-value))
+
+
 (defun find-largest-post-id ()
   #.(locally-enable-sql-reader-syntax)
   (prog1
@@ -312,6 +387,16 @@
     #.(restore-sql-reader-syntax-state)))
 
 
+(defun make-journal-pingback-id ()
+  #.(locally-enable-sql-reader-syntax)
+  (prog1
+      (1+ (or (single-object (select [max [slot-value 'journal-pingback 'id]]
+                                     :from [journal-pingback]
+                                     :flatp t))
+              -1))
+    #.(restore-sql-reader-syntax-state)))
+
+
 (defun find-entry (number)
   #.(locally-enable-sql-reader-syntax)
   (prog1
diff --git a/journal.lisp b/journal.lisp
index 74dfb40..54b140d 100755
--- a/journal.lisp
+++ b/journal.lisp
@@ -49,7 +49,8 @@
         (:view-atom-entry (values "/~D/atom" post-id))
         (:save (values "/~D/save" post-id))
         (:moderation-page "/moderate")
-        (:css "/../journal.css")))))
+        (:css "/../journal.css")
+        (:pingback "/rpc")))))
 
 
 (defun show-comment-feed ()
@@ -424,6 +425,7 @@
     (http-add-header "Last-Modified" (http-timestamp (compute-journal-last-modified-date)))
     (http-add-header "Content-Language" "de")
     (http-add-header "Cache-Control" "public")
+    (http-add-header "X-Pingback" (link-to :pingback :absolute t))
     (http-send-headers "text/html; charset=UTF-8"))
 
   (<xhtml :xmlns "http://www.w3.org/1999/xhtml"
@@ -460,6 +462,7 @@
             :type "application/atom+xml"
             :href (link-to :view-atom-entry)
             :title "Kompottkins Weisheiten")
+    (<:link :rel "pingback" :href (link-to :pingback :absolute t))
     (<:link :rel "stylesheet" :type "text/css" :href (link-to :css))
     (<:link :rel "openid.server" :href "https://meinguter.name/index.php/serve")
     (<:link :rel "openid.delegate" :href "https://matthias.benkard.meinguter.name")
@@ -586,6 +589,18 @@
      (<:div :class :journal-comment-body
       (<:as-html (render-comment-body excerpt))))))
 
+(defun show-pingback (pingback)
+  (with-slots (date id url)
+      pingback
+    (<:div :class :journal-comment
+           :id (format nil "pingback-~D" id)
+     (<:div :class :journal-comment-header
+      (<:as-html (format nil "(~A) "
+                         (format-date nil "%day%.%mon%.%yr%, %hr%:%min%" date)))
+      (<:as-html "Pingback von ")
+      (<:a :href url :rel "nofollow" (<:as-html url))
+      (<:as-html ".")))))
+
 (defun show-moderation-page ()
   #.(locally-enable-sql-reader-syntax)
   (revalidate-cache-or-die "text/html; charset=UTF-8")
@@ -613,6 +628,29 @@
         (<:button :type "submit" (<:as-is "Annehmen")))
       (<:div (<:as-html "Zu: ") (<:a :href (link-to :view :post-id (id-of (entry-of trackback)) :absolute t) (<:as-html (title-of (entry-of trackback)))))
       (show-trackback trackback))
+    (<:h2 (<:as-html "Pingbacks"))
+    (dolist (pingback (select 'journal-pingback :flatp t :order-by '([date]) :where (clsql:sql-null [spam_p])))
+      (<:hr)
+      (<:form :action (link-to :moderation-page)
+              :method "post"
+              :accept-charset "UTF-8"
+              :enctype "application/x-www-form-urlencoded"
+              :style "display: inline"
+        (<:input :type "hidden" :name "id" :value (prin1-to-string (id-of pingback)))
+        (<:input :type "hidden" :name "type" :value "pingback")
+        (<:input :type "hidden" :name "acceptp" :value "f")
+        (<:button :type "submit" (<:as-is "Verwerfen")))
+      (<:form :action (link-to :moderation-page)
+              :method "post"
+              :accept-charset "UTF-8"
+              :enctype "application/x-www-form-urlencoded"
+              :style "display: inline"
+        (<:input :type "hidden" :name "id" :value (prin1-to-string (id-of pingback)))
+        (<:input :type "hidden" :name "type" :value "pingback")
+        (<:input :type "hidden" :name "acceptp" :value "t")
+        (<:button :type "submit" (<:as-is "Annehmen")))
+      (<:div (<:as-html "Zu: ") (<:a :href (link-to :view :post-id (id-of (entry-of pingback)) :absolute t) (<:as-html (title-of (entry-of pingback)))))
+      (show-pingback pingback))
     (<:h2 (<:as-html "Kommentare"))
     (dolist (comment (select 'journal-comment :flatp t :order-by '([date]) :where (clsql:sql-null [spam_p])))
       (<:hr)
diff --git a/main.lisp b/main.lisp
index 239202b..1a8ce85 100644
--- a/main.lisp
+++ b/main.lisp
@@ -153,8 +153,8 @@
     (:moderate (let* ((id (getf *query* :id nil))
                       (type (getf *query* :type nil))
                       (acceptp (getf *query* :acceptp nil))
-                      (table (if (string= type "trackback")
-                                 'journal_trackback
+                      (table (cond ((string= type "trackback") 'journal_trackback)
+                                   ((string= type "pingback") 'journal_pingback)
                                  'journal_comment)))
                  (with-transaction ()
                    (when (and id type acceptp (string= acceptp "t"))
diff --git a/utils.lisp b/utils.lisp
index 762a6dd..5476747 100644
--- a/utils.lisp
+++ b/utils.lisp
@@ -367,6 +367,21 @@ ELEMENT-TYPE as the stream's."
                 (spamp comment)
                 (excerpt-of comment))))
 
+(defun mail-pingback (address pingback entry)
+  (declare (type journal-pingback pingback))
+  (mail address
+        (format nil "[Pingback] ~A" (title-of entry))
+        (format nil "~&Pingback von: ~A~
+                     ~&Nummer: ~A~
+                     ~&IP-Adresse: ~A~
+                     ~&Webbrowser: ~A~
+                     ~&Als Spam erkannt: ~A"
+                (url-of pingback)
+                (id-of pingback)
+                (submitter-ip pingback)
+                (submitter-user-agent pingback)
+                (spamp pingback))))
+
 (defun revalidate-cache-or-die (content-type)
   (when (eq *mode* :http)
   #+clisp
diff --git a/xml-rpc-functions.lisp b/xml-rpc-functions.lisp
index 2fa729f..b11a297 100644
--- a/xml-rpc-functions.lisp
+++ b/xml-rpc-functions.lisp
@@ -104,4 +104,34 @@
       (setf (entry-type-of entry) (or entry-type "html"))
       (update-records-from-instance entry)
       ;; Update static files.
-      (update-journal))))
\ No newline at end of file
+      (update-journal))))
+
+
+(defun mulk.journal.xml-rpc::|pingback.ping| (source-uri target-uri)
+  #.(locally-enable-sql-reader-syntax)
+  (prog1
+    (let* ((last-uri-component (first (split-sequence #\/ target-uri :from-end t :count 1)))
+           (entry-id (ignore-errors (parse-integer last-uri-component)))
+           (entry (and entry-id (ignore-errors (find-entry entry-id)))))
+      (unless entry
+        (error (make-condition 'xml-rpc-fault :code #x20)))
+      (with-transaction ()
+        (let ((existing-pingbacks
+               (select 'journal-pingback
+                       :where [and [= [slot-value 'journal-pingback 'entry-id] entry-id]
+                                   [= [slot-value 'journal-pingback 'url] source-uri]]
+                       :flatp t)))
+          (when existing-pingbacks
+            (error (make-condition 'xml-rpc-fault :code #x30)))
+          (let ((pingback (make-instance 'journal-pingback
+                             :id (make-journal-pingback-id)
+                             :entry-id entry-id
+                             :uuid (make-uuid)
+                             :date (get-universal-time)
+                             :url source-uri
+                             :submitter-ip (http-getenv "REMOTE_ADDR")
+                             :submitter-user-agent (http-getenv "HTTP_USER_AGENT"))))
+            (update-records-from-instance pingback)
+            (when (eq *site* :nfs.net)
+              (mail-pingback *notification-email* pingback entry))))))
+    #.(restore-sql-reader-syntax-state)))