diff options
| -rw-r--r-- | journal-content.lisp | 85 | ||||
| -rwxr-xr-x | journal.lisp | 40 | ||||
| -rw-r--r-- | main.lisp | 4 | ||||
| -rw-r--r-- | utils.lisp | 15 | ||||
| -rw-r--r-- | xml-rpc-functions.lisp | 32 |
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) @@ -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")) @@ -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))) |