From 36aa75be02ff29571830d9f529cd4515bfeebbab Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Fri, 6 Nov 2009 13:52:52 +0100 Subject: Support pingbacks. Ignore-this: 534fc0ed2f9e22c9b6a92cde14bedf2f darcs-hash:d70c51f9d5d9002dab339dd6ceb79fef2cd89f27 --- xml-rpc-functions.lisp | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) (limited to 'xml-rpc-functions.lisp') 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))) -- cgit v1.2.3