summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--journal-content.lisp85
-rwxr-xr-xjournal.lisp40
-rw-r--r--main.lisp4
-rw-r--r--utils.lisp15
-rw-r--r--xml-rpc-functions.lisp32
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)))