Update of /project/cl-blog/cvsroot/cl-blog In directory common-lisp.net:/tmp/cvs-serv2156 Modified Files: cl-blog.asd cl-blog.lisp trackback.lisp Log Message: Final details on implementation of trackback ping Date: Wed Oct 20 03:30:11 2004 Author: bmastenbrook Index: cl-blog/cl-blog.asd diff -u cl-blog/cl-blog.asd:1.1.1.1 cl-blog/cl-blog.asd:1.2 --- cl-blog/cl-blog.asd:1.1.1.1 Sun Oct 17 22:40:42 2004 +++ cl-blog/cl-blog.asd Wed Oct 20 03:30:09 2004 @@ -1,5 +1,5 @@ ;;;; Silly emacs, this is -*- Lisp -*- -;;;; $Id: cl-blog.asd,v 1.1.1.1 2004/10/17 20:40:42 bmastenbrook Exp $ +;;;; $Id: cl-blog.asd,v 1.2 2004/10/20 01:30:09 bmastenbrook Exp $ ;;;; $Source: /project/cl-blog/cvsroot/cl-blog/cl-blog.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -20,4 +20,5 @@ :cl-base64 :md5 :html-encode :cl-ppcre) :components ((:file "package") (:file "variable" :depends-on ("package")) - (:file "cl-blog" :depends-on ("package" "variable")))) \ No newline at end of file + #+sbcl (:file "trackback") + (:file "cl-blog" :depends-on ("package" "variable" #+sbcl "trackback")))) \ No newline at end of file Index: cl-blog/cl-blog.lisp diff -u cl-blog/cl-blog.lisp:1.3 cl-blog/cl-blog.lisp:1.4 --- cl-blog/cl-blog.lisp:1.3 Tue Oct 19 03:38:12 2004 +++ cl-blog/cl-blog.lisp Wed Oct 20 03:30:09 2004 @@ -14,6 +14,7 @@ ((title :initarg :title :accessor trackback-title) (url :initarg :url :accessor trackback-url) (excerpt :initarg :excerpt :accessor trackback-excerpt) + (time :initarg :time :accessor trackback-time) (blog-name :initarg :blog-name :accessor trackback-blog-name))) (defvar *blog-entries* nil) @@ -159,11 +160,12 @@ *entry-path*)) (defun make-trackback-constructor (trackback) - (with-slots (title url excerpt blog-name) trackback + (with-slots (title url excerpt time blog-name) trackback `(make-instance 'trackback :title ,title :url ,url :excerpt ,excerpt + :time ,time :blog-name ,blog-name))) (defun blog-entry-write-to-file (entry) @@ -230,7 +232,8 @@ :time (get-universal-time) :contents contents))) (push new-entry *blog-entries*) - (blog-entry-write-to-file new-entry))) + (blog-entry-write-to-file new-entry) + new-entry)) (defun change-blog-entry (entry &key (category (blog-entry-category entry)) (title (blog-entry-title entry)) @@ -480,7 +483,8 @@ (defun format-entry (entry &key (display-link t) (display-actions t)) `((div :class "entry") - ,(format nil "<!-- + ,@(if display-actions + (list (format nil "<!-- <rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\" xmlns:dc=\"http://purl.org/dc/elements/1.1/\" xmlns:trackback=\"http://madskills.com/public/xml/rss/module/trackback/\"> @@ -491,7 +495,7 @@ trackback:ping=\"~A\" /> </rdf:RDF> --> -" (entry-link entry) (entry-link entry) (blog-entry-title entry) (entry-trackback entry)) +" (entry-link entry) (entry-link entry) (blog-entry-title entry) (entry-trackback entry)))) ((div :class "entry-head") (h2 ,(blog-entry-title entry)) @@ -514,7 +518,10 @@ `(((div :class "entry-footer") ,@(if display-link `(((a :class "entry-footer" :href ,(entry-link entry)) - "Permanent Link"))) + ,(if (blog-entry-trackbacks entry) + (format nil "Permanent Link (~A)" + (length (blog-entry-trackbacks entry))) + "Permanent Link")))) " | " ((a :class "entry-footer" :href ,(edit-entry-link entry)) "Edit") @@ -525,11 +532,12 @@ (defun format-trackback (trackback) `((div :class "entry") ((div :class "entry-head") - ((:a :href ,(encode-for-http (trackback-url trackback))) + ((:a :href ,(trackback-url trackback)) ,(encode-for-pre (trackback-title trackback))) ((div :class "entry-data") "From " - ,(encode-for-pre (trackback-blog-name trackback)) + (i ,(encode-for-pre (trackback-blog-name trackback))) + " on " ,(format-entry-date (trackback-time trackback)) )) ((div :class "entry-text") ,(encode-for-pre (trackback-excerpt trackback))) @@ -744,6 +752,34 @@ (request-stream request) `(html (body (h1 "No page for you!")))))))) +(defun search-for-trackbacks-for-text (text) + (let ((url-regexp "(?i)(http://[^ \"]+)([ .,)!?\"]|$)")) + (loop for (match new-begin) = (multiple-value-list (cl-ppcre:scan url-regexp text)) + for url = nil + while match + do (let ((got-url (elt (nth-value 1 (cl-ppcre:scan-to-strings url-regexp text)) 0))) + (setf text (subseq text new-begin)) + (setf url got-url)) + if url collect url))) + +(defun strip-html (text) + (cl-ppcre:regex-replace-all "<(\"[^\"]+\"|[^>\"])*>" text "")) + +(defun autotrackback-entry (entry) + ;; Right now, trackback.lisp is only present on SBCL. + #+sbcl + (let ((urls (search-for-trackbacks-for-text (blog-entry-contents entry)))) + (format t "urls is ~S~%" urls) + (loop for url in urls + for ping = (trackback:autodetect-ping-for-url url) + if ping + do (trackback:ping ping :title (urlstring-escape (blog-entry-title entry)) + :url (urlstring-escape (entry-link entry)) + :excerpt (urlstring-escape (strip-html (blog-entry-contents entry))) + :blog-name *blog-short-name*) + if ping + collect url))) + (defmethod handle-request-response ((handler new-entry-handler) (method (eql :post)) request) (with-body-params ((title "title") (category "category") @@ -774,11 +810,19 @@ :contents contents ))) (if (not (find 0 (list title category contents) :key #'length)) - (progn - (new-blog-entry :title title :category category :contents contents) - (blog-wrap-page "Posted" - '(((div :id "entry-form") - (h2 "Your new entry has been posted."))))) + (let* ((entry + (new-blog-entry :title title :category category :contents contents)) + (urls-pinged (ignore-errors (autotrackback-entry entry)))) + (blog-wrap-page "Posted" + `(((div :id "entry-form") + (h2 "Your new entry has been posted.") + ,@(when urls-pinged + `("Trackback pings have been sent to the following URLs:" + (ul + ,@(mapcar #'(lambda (url) + `(li ((a :href ,url) ,url))) + urls-pinged)))) + )))) (blog-wrap-page "Not posted" '(((div :id "entry-form") (h2 "Please fill in all fields!")))))))))) @@ -805,7 +849,8 @@ ") (let ((trackback (make-instance 'trackback :title title :url url - :excerpt excerpt :blog-name blog-name))) + :excerpt excerpt :time (get-universal-time) + :blog-name blog-name))) (setf (blog-entry-trackbacks entry) (nconc (blog-entry-trackbacks entry) (list trackback))) (blog-entry-write-to-file entry) @@ -830,8 +875,9 @@ (blog-wrap-page (format nil "~A: ~A" *blog-short-name* (blog-entry-title entry)) - (cons (format-entry entry) - (mapcar #'format-trackback (blog-entry-trackbacks entry))))))) + (list* (format-entry entry) + `(p "Trackback pings for this entry are listed below. The URL to ping for this entry is: " ((a :href ,(entry-trackback entry)) ,(entry-trackback entry))) + (mapcar #'format-trackback (blog-entry-trackbacks entry))))))) (defclass email-redirect-handler (handler) ()) Index: cl-blog/trackback.lisp diff -u cl-blog/trackback.lisp:1.1 cl-blog/trackback.lisp:1.2 --- cl-blog/trackback.lisp:1.1 Tue Oct 19 03:33:06 2004 +++ cl-blog/trackback.lisp Wed Oct 20 03:30:09 2004 @@ -1,8 +1,8 @@ ;;;; trackback.lisp - standalone trackback ping (defpackage :trackback - (:use :common-lisp :sb-bsd-sockets :split-sequence) - (:export :ping)) + (:use :common-lisp :sb-bsd-sockets :split-sequence :cl-ppcre) + (:export :ping :autodetect-ping-for-url)) (in-package :trackback) (defun encode (str table) @@ -35,31 +35,54 @@ (string (code-char 13)) (string (code-char 10))))) -(defun url-post (url content-type content) - (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) - (host (url-host url)) - (port (url-port url))) - (declare (ignore port)) +(defun open-socket (host port) + (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) (socket-connect - s (car (host-ent-addresses (get-host-by-name (url-host url)))) - (url-port url)) - (let ((stream (socket-make-stream s :input t :output t :buffering :full))) - ;; we are exceedingly unportable about proper line-endings here. - ;; Anyone wishing to run this under non-SBCL should take especial care - (format stream "POST ~A HTTP/1.1~AHost: ~A~AUser-Agent: CLiki Bot~AContent-Type: ~A~AContent-Length: ~D~A~A~A" url +crlf+ host +crlf+ +crlf+ content-type +crlf+ (length content) +crlf+ +crlf+ content) - (force-output stream) - (list - (let* ((l (read-line stream)) - (space (position #\Space l))) - (parse-integer l :start (1+ space) :junk-allowed t)) - (loop for line = (read-line stream nil nil) - until (or (null line) (eql (length line) 0) (eql (elt line 0) (code-char 13))) - collect - (let ((colon (position #\: line))) - (cons (intern (string-upcase (subseq line 0 colon)) :keyword) - (string-trim (list #\Space (code-char 13)) - (subseq line (1+ colon)))))) - stream)))) + s (car (host-ent-addresses (get-host-by-name host))) + port) + (socket-make-stream s :input t :output t :buffering :full))) + +(defun http-post (url content-type content) + (let* ((host (url-host url)) + (port (url-port url)) + (stream (open-socket host port))) + ;; we are exceedingly unportable about proper line-endings here. + ;; Anyone wishing to run this under non-SBCL should take especial care + (format stream "POST ~A HTTP/1.1~AHost: ~A~AUser-Agent: CLiki Bot~AContent-Type: ~A~AContent-Length: ~D~A~A~A" url +crlf+ host +crlf+ +crlf+ content-type +crlf+ (length content) +crlf+ +crlf+ content) + (force-output stream) + (list + (let* ((l (read-line stream)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) + (loop for line = (read-line stream nil nil) + until (or (null line) (eql (length line) 0) (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) + stream))) + +(defun http-get (url) + (let* ((host (url-host url)) + (port (url-port url)) + (stream (open-socket host port))) + ;; we are exceedingly unportable about proper line-endings here. + ;; Anyone wishing to run this under non-SBCL should take especial care + (format stream "GET ~A HTTP/1.0~%Host: ~A~%User-Agent: CLiki Bot~%~%" url host) + (force-output stream) + (list + (let* ((l (read-line stream)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) + (loop for line = (read-line stream nil nil) + until (or (null line) (zerop (length line)) (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) + stream))) (defun mini-xml-read (xml-string) (let ((cur-xml (list nil)) @@ -120,7 +143,7 @@ (handler-case (sb-ext:with-timeout 5 (destructuring-bind (response headers stream) - (url-post trackback-url "application/x-www-form-urlencoded" + (http-post trackback-url "application/x-www-form-urlencoded" (format nil "~{url=~A&title=~A&excerpt=~A&blog_name=~A~}" (mapcar #'encode-for-url (list url title excerpt blog-name)))) @@ -161,4 +184,37 @@ (values nil "Unknown error") t))) (if stream (close stream))))) - (sb-ext:timeout () (values nil "Recieved timeout"))))) + (serious-condition () (return-from ping nil))))) + +(defmacro aif2 (test-form if-form &optional else-form) + (let ((test-val (gensym))) + `(multiple-value-bind (,test-val it) ,test-form + (if ,test-val + ,if-form + ,@(if else-form (list else-form)))))) + +(defun autodetect-ping-for-url (url) + (handler-case + (sb-ext:with-timeout 2 + (destructuring-bind (response headers stream) (http-get url) + (declare (ignore headers)) + (unwind-protect + (if (not (eql response 200)) + (return-from autodetect-ping-for-url nil) + (progn + (loop for line = (read-line stream nil nil) + with in-rdf = nil + with found = nil + while line + do (progn + (if (scan "(?i)<rdf:description" line) + (setf in-rdf t)) + (aif2 (scan-to-strings "(?i)rdf:about=\"(.+)\"" line) + (if (string= (elt it 0) url) + (setf found t))) + (aif2 (and found (scan-to-strings "(?i)trackback:ping=\"(.+)\"" line)) + (return-from autodetect-ping-for-url (elt it 0))) + (when (scan "(?i)</rdf:rdf>" line) + (setf in-rdf nil) + (setf found nil))))))))) + (serious-condition () (return-from autodetect-ping-for-url nil)))) \ No newline at end of file